DUDLEY 


NAVAL  POSTGRADUATE  SCHOOL 

Monterey,  California 


THESIS 


IMPLEMENTATION  OF  A  COMPILER 
FUNCTIONAL  PROGRAMMING  LANGUAGE 

FOR  THE 
PHI  -  (D 

by 

Eugene  J.  Cole 
and 
Joseph  E.  Connell 

II 

June  1987 

Th 

esis  Advisor: 

Daniel 

Davis 

Approved  for  public  release;  distribution  is  unlimited 


T 233190 


UNCLASSIFIED 

security  ClaSS. fiCaTiQn  Of  Tm.S   paGE 


REPORT  DOCUMENTATION  PAGE 


'a  seport  security  classification 
Unclassified 


'b    RESTRICTIVE   MARKINGS 


2a  SfCuR'TY  classification  authority 


2b    DtCASS  FiCAT.QN  ■  DOWNGRADING   SCHEDULE 


3     DISTRIBUTION/  AVAILABILITY  OF    REPORT 

Approved  for  public  release; 
Distribution  is  Unlimited 


1    PERFORM. NG  ORGANIZATION  REPORT  NuMBER(S) 


S     MON1TOR1NG   ORGANIZATION   REPORT   NUM3£P(S) 


6a    NAME  OF  PERFORMING  ORGANiZAT.ON 

Naval  Postgraduate  School 


6b    OFF.CE  SYMBOL 
(if  applicable) 

Code    52 


7a    NAME   OF   MONiTORiNG   ORGANIZATION 

Naval  Postgraduate  School 


6<    ADDRESS    Cry    Stare    and  ZIP  Cod*) 

Monterey,  California   939^3-5000 


b     ADDRESS  (O'fy,   State    and  ZIP  Code) 

Monterey,  California   93943-5000 


8a    NAME  OF  FUNDING  .  SPONSORING 
ORGAN'ZAT  ON 


8b    OFFICE  SYMBOL 
(it  apphcabie) 


9    PROCUREMENT  INSTRUMENT   IDEN  T.F  NATION    NUMBER 


8c    ADDRESS  (Cry    Sfare  and  ZIP  Cod*) 


'0    SOURCE   OF   FUNDING  NUMBERS 


PROGRAM 
ELEMENT  NO 


PROJECT 

NO 


TAS< 
NO 


WORK     jNI  T 
ACCESSION   NO 


''     T  ".£   (include   Security  Classification) 

IMPLEMENTATION  OP  A  COMPILER  FOR  THE  FUNCTIONAL  PROGRAMMING 
LANGUAGE  PHI  -  03  (u) 


1  PERSONAL  AuThOR(S) 

!ole,  Eugene  J.  and  Connell,  Joseph  E 


jj     -yP£   OF   p.fpOR'' 

"■(aster's    Thesis 


3b    'ME   COVERED 

FROM  TQ 


14    DATE  OF   REPORT    (Year  Month  Day) 

19  87    June 


15    PAG£    .  Dl-NT 

1"" 


6   Supplementary  notat:qn 


COSAT.  CODES 


group 


Su9-GR0UP 


8    SUBJECT    tERMS  \Contmue  on  revert*  if  neceisary   and  identify   by  block   number) 

Functional  Language;  Applicative  Languages; 
Compiler  Design 


9  ASS-RjiCT 

This 

for  the 

1  z  e  1  a  n 

concept 

machine 

technics 

p  a  s  s  s  e 

Sine 

nualiti 

functio 

na tural 

present 

to  a  fu 

{Continue  on  reverse  it  necessary   and  identify  by  bloxk   number) 

thesis  describes  the  design  and  implement 
functional  programming  language  PHI.   The 
d  the  authors  think  this  should  facilitate 
and  implementation.   The  front-end  of  the 
independent  lexical  and  syntactic  analyze 
ues  are  employed.   The  back-end  implements 
mantic  analyzer  and  code  generator, 
e  this  implementation  is  a  prototype,  it  d 
es  desirable  in  a  full  implementation.   Th 
ns  and  data  definitions  are  implemented,  a 
number,  and  boolean  types.   However,  the 
and  the  design  is  mature  enough  to  allow 
11  imclementation . 


of  a  prototy 
design  is  hi 
the  understa 
compiler  imp 
•s:  too-down 


pe  comrii 
ghly  modu 
nding  of 
lements 


er 
lar- 

both 


parsing 
a  machine  dependent  one- 


oes  not  posse 
e  basic  contr 
s  well  as  the 
necessary  hoo 
expanding  the 


ss  all  of 
ucts  of  F 

integer, 
ks  are 

prototvn 


HI: 


:0     I'TM/ON     AVAILABILITY  OF   ABSTRACT 

(Z.  .NClASSiF'ED-'uNL'MITED       □  SAME  AS   RPT  D  DTiC   USERS 


21     ABSTRACT  SECURITY   CLASSiFiCAtiON 


nclassif ied 


>a    NAME   OF   RESPONSIBLE    NOiViOUAl 

"rsf.  Daniel  Davis 


22b 


TELEPHONE  (Include  ArtaCod*) 

646-309  1 


(408 


22c    OFFICE    SyMBO: 

Code    5  2~v 


DD  FORM  1473,  84  mar 


83  APR  edition  -ray  be  used  until  e«hauiTed 
All  other  edt.om  are.  obsolete 


SECURITY   CLASSIFICATION   QF    'mS 


TWL 


ur 


Approved  for  public  release;  distribution  is  unlimited. 

Implementation  of  a  Compiler  for  the 
Functional  Programming  Language  PHI  —  O 

by 

Eugene  J.  Cole 

Major,  United  States  Marine  Corps 
B.  A.,  The  Citadel,  1975 

and 

Joseph  E.  Connell  II 

Captain,  United  States  Marine  Corps 
B.  S.,  University  of  Missouri  —  Rolla,  1974 

Submitted  in  partial  fulfillment  of  the 
requirements  for  the  degree  of 

MASTER  OF  SCIENCE  IN  COMPUTER  SCIENCE 

from  the 

NAVAL  POSTGRADUATE  SCHOOL 
June  1987 


ABSTRACT 

This  thesis  describes  the  design  and  implement  of  a  prototype  compiler  for  the 
functional  programming  language  PHI.  The  design  is  highly  modularized  and  the  authors 
think  this  should  facilitate  the  understanding  of  both  concept  and  implementation.  The 
front-end  of  the  compiler  implements  machine  independent  lexical  and  syntactic  analyzers; 
top-down  parsing  techniques  are  employed.  The  back-end  implements  a  machine 
dependent  one-pass  semantic  analyzer  and  code  generator. 

Since  this  implementation  is  a  prototype,  it  does  not  possess  all  of  the  qualities 
desirable  in  a  full  implementation.  The  basic  constructs  of  PHI:  functions  and  data 
definitions  are  implemented,  as  well  as  the  integer,  natural  number,  and  boolean  types. 
However,  the  necessary  hooks  are  present  and  the  design  is  mature  enough  to  allow 
expanding  the  prototype  to  a  full  implementation. 
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I.    INTRODUCTION 

A.    BACKGROUND  —  GENERAL 

In  its  attempt  to  provide  students  with  a  well  rounded  background  to  the  field  of 
computer  science,  the  computer  science  department  at  the  Naval  Postgraduate  School  offers 
courses  covering  recent  developments  in  programming  languages.  One  of  the  courses 
deals  specifically  with  the  methodology  of  functional,  also  known  as  applicative, 
programming.  Both  the  theory  and  the  practice  of  functional  programming  are  covered, 
concentrating  more  on  the  practice  than  the  theory.  In  order  to  fully  appreciate  the  nuances 
of  functional  programming  it  would  be  desirable  to  provide  the  students  with  a  functional 
programming  environment.  This  would  provide  a  first  hand  look  at  the  fundamental  dif- 
ference in  methodologies  when  programming  in  functional  languages  as  opposed  to 
programming  in  traditional  imperative  languages. 

Of  the  languages  currently  supported  in  the  department;  LISP,  on  the  UNIX1 
environment,  comes  the  closest  to  meeting  this  requirement.  Although  LISP  is  considered 
a  functional  language  by  some,  its  many  extensions  and  modifications  actually  brings  it  into 
the  world  of  imperative  prograinming.  It  is  not  a  pure  functional  programming  language. 

There  are  several  additional  problems  associated  with  using  LISP  to  teach  techniques 
of  functional  programming.  Modem  LISP  dialects  do  not  support  all  aspects  of  functional 
programming.  Most  notably  they  lack  the  ability  to  define  higher-order  functions. 
Dynamic  scoping  and  the  semantics  of  the  language  make  it  a  pedagogical  nightmare  to 
teach. [Ref.  l:p.  0-1]  The  goal  of  teaching  functional  programming  would  rapidly  be 
overtaken  by  the  necessity  of  explaining  the  idiosyncrasies  of  LISP.    In  an  11  week 


UNIX  is  a  trademark  of  Bell  Laboratories. 


quarter,  time  devoted  to  LISP  would  significantly  detract  from  instruction  of  functional 
programming. 

Recognizing  the  shortcomings  of  LISP,  a  pure  functional  language,  PHI  was 
developed  by  Dr.  B.  J.  MacLennan  for  use  in  this  course  of  instruction.  The  syntax  of 
PHI  closely  follows  that  of  standard  mathematical  notation.  This  means  students  should 
have  little  difficulty  in  learning  how  to  write  legitimate  PHI  statements.  Instruction  can 
now  concentrate  on  joining  these  statements  to  create  functional  programs.  Hopefully,  this 
will  lead  to  a  greater  understanding  and  appreciation  of  the  methodology  of  functional 
programming. 

B.    BACKGROUND  —  THESIS 

Creation  of  PHI  solved  the  problem  of  finding  a  suitable  language  to  use  to 
demonstrate  the  methodology  of  functional  programming.  However,  currently  PHI 
programs  are  programs  on  paper  only.  There  exists  no  programming  environment  for  the 
PHI  language.  So  it  is  impossible  to  machine  execute  PHI  programs.  This  thesis  attempts 
to  remedy  the  above  problem  by  providing  the  first  component  in  a  PHI  programming 
environment  —  a  prototype  PHI  compiler. 

Conventional  compiler  construction  techniques  were  chosen  for  this  implementation 
for  several  reasons.  By  choosing  conventional  techniques,  the  authors  were  able  to 
address  the  problems  associated  with  utilizing  conventional  methods  for  implementing  a 
compiler  for  a  functional  language2.  Additionally,  realizing  that  both  the  language  and 
system  would  change,  the  authors  wanted  a  well  documented  and  understood 
methodology.  The  cost  of  maintaining  a  system  can  be  as  much  as  three  times  the 
development  cost  [Ref.  2:p.  478].  Therefore,  it  was  imperative  to  choose  a  methodology 
that  supported  a  clean  and  structured  design. 


2Specific  problems  and  solutions  are  covered  later  in  Chapters  Two  and  Three 


Following  conventional  methodologies,  the  authors  separated  the  PHI  compiler  design 
into  a  front-end3  and  a  back-end4.  The  overall  general  design  of  the  PHI  compiler  is 
shown  in  Figure  1.1.  The  front-end,  containing  the  scanner  (lexical  analyzer)  and  parser 
(syntactic  analyzer)  is  essentially  responsible  for  analysis  of  the  external  file  containing  the 
source  program.  The  PHI  compiler  back-end  couples  semantic  analysis  with  code 
generation  to  produce  code  suitable  for  execution  on  the  target  machine.  [Ref.  3:pp.  5-6] 
The  authors  felt  that  a  clear  and  distinct  separation  between  parts  would  aid  understanding 
of  the  system,  simplify  division  of  labor,  and  increase  ease  of  development  and 
maintenance.  It  should  also  result  in  greater  flexibility  for  follow-on  development  in  the 
PHI  programming  environment.  As  an  example,  the  current  front-end  could  be  modified 
to  support  a  PHI  interpreter. 
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Figure  1.1  General  Design  of  the  PHI  Compiler 

C.    BACKGROUND  —  FUNCTIONAL  PROGRAMMING 

Functional  programming  is  a  methodology  in  favor  among  academicians.  Although 
applicative  programming  goes  further  back,  it  is  generally  agreed  that,  as  a  methodology, 
functional  programming  traces  its  roots  to  John  Backus  [Ref.  4:p.  404,  Ref.  5:p.  65].  In 


^Design  and  implementation  of  the  front-end  is  discussed  in  Chapter  Two. 
4Design  and  implementation  of  the  back-end  is  discussed  in  Chapter  Three. 
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his  acceptance  speech  for  the  1977  ACM  Turing  Award,  Backus  criticized  traditional 
programming  languages  and  programming  styles.  He  went  on  to  propose  a  new 
methodology  of  programming  that  involved  "the  use  of  a  fixed  set  of  combining  forms 
called  functional  forms."  [Ref.  6:p.  619]  This  methodology  is  known  today  as  functional 
programming. 

1.   Problems  with  Conventional  Languages 

Backus  feels  [Ref.  6:pp.  613-619]  that  the  basic  underlying  problem  with 
conventional  languages  is  the  existence  of  the  assignment  statement.  The  assignment 
statement  plays  a  central  role  in  conventional  languages  and  breaks  programming  into  two 
worlds.  Backus  calls  the  right-hand  side  of  assignment  statements,  expressions,  the  first 
of  these  worlds.  The  second  world  is  the  world  of  statements,  with  the  primary  statement, 
of  course,  being  the  assignment  statement. 

Several  problems  are  associated  with  assignment  statements.   First,  they  permit 

programs  to  be  held  hostage  through  access  to  their  variables.  Since  variables  are  used  to 

imitate  the  machine's  storage  cells;  assignment  statements  allow,  even  encourage,  state 

changes  to  take  place.  This  access,  either  direct  or  indirect,  permits  such  problems  as  side 

effects,  unintentional  state  changes,  and  aliasing  to  arise.    It  then  becomes  difficult  to 

reason  about  the  correctness  of  these  programs,  so  proving  simple  programs  correct  is  an 

arduous  task  and  proving  complex  programs  correct  is  virtually  impossible.  Additionally, 

by  permitting  the  value  of  variables  to  be  changed,  the  assignment  statement  makes 

temporal  order  of  execution  of  statements  critical.  For  example,  the  following  two  pieces 

of  code  produce  dramatically  different  results  depending  on  which  statement  inside  the  for 

loop  is  executed  first. 

for  (i  =  0;  i  !=  some_value;  ++i)  for  (i  =  0;  i  !=  some_value;  ++i) 

{  if(  i  %  2  ==  0)  {  DoSomething(i); 

continue;  if(  i  %  2  ==  0); 

DoSomething(i);  continue; 

}  } 


These  problems  interact  so  that  it  becomes  extremely  difficult  to  create  new  programs  out  of 
old  ones.  [Re'f.  6:pp.  613  -  619,  Ref.  l:pp.   1-2  -  1-20] 

Another  problem  associated  with  assignment  statements  is  that  each  produces  only 
a  one-word  result.  In  effect,  they  force  programmers  to  think  in  a  word-at-a-time 
manner.  For  example,  to  apply  a  function  to  an  entire  array  of  values,  the  programmer 
must  access  each  value  individually.  Not  only  is  this  wasteful  of  computer  assets,  but  it 
results  in  what  Backus  refers  to  as  the  "von  Neumann  bottleneck"  of  conventional 
programming  languages.  [Ref.  6:pp.  613-619] 
2.   Functional  Languages 

Backus  proposes  the  methodology  of  functional  programming  as  the  solution  to 
these  problems.  Functional  languages  have  removed  variables  and  the  assignment 
statement  from  their  syntax  so  that  their  basic  building  block  becomes  the  function.  It  is 
through  "the  use  of  a  fixed  set  of  combining  forms... plus  simple  definitions"  [Ref.  6:p. 
619]  that  the  programmer  is  able  to  build  new  functions  from  existing  functions.  It  thus 
becomes  possible  to  form  a  new  program  by  combining  two  or  more  existing  programs  or 
functions  together. 

The  absence  of  assignment  statements  and  variables  removes  the  problems 
plaguing  conventional  languages  caused  by  side  effects,  etc.  because  the  program  now 
operates  exclusively  in  the  world  of  expressions.  This  permits  the  programmer  to  maintain 
a  clear  conceptual  view  of  the  program.  It  is  easier  to  understand  and  reason  about  the  task 
the  program  is  to  perform  [Ref.  5:pp.  65  -  69].  It  now  becomes  not  only  possible,  but 
practical  to  prove  programs  correct  [Ref.6:pp.  624  -  625]. 

Another  direct  benefit  stemming  from  the  absence  of  side  effects  is  order.  The 
values  of  expressions  are  no  longer  dependent  on  the  order  in  which  they  are  evaluated. 
Therefore,  functional  languages  provide  a  natural  means  of  performing  parallel 
computations  [Ref.  7:p.    35].   Functional  languages  and  the  associated  methodology  of 
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functional  programming  may  very  well  provide  the  key  to  programming  the  massively 
parallel  computers  entering  service  nowadays.  All  of  the  above  benefits  have  applicability 
to  ongoing  research  in  the  SDI  program. 

The  authors  feel  that  functional  programming  can  best  be  summarized  by  the 
following  thought  —  assignment  statements  are  to  functional  programming  what  GOTO 
statements  are  to  structured  programming. 

D.    ASSUMPTIONS 

An  IBM5  personal  computer/IBM  compatible  personal  computer  was  chosen  as  the 
target  machine  for  this  implementation.  The  authors  felt  that  the  nature  of  the  language  and 
its  intended  use  were  better  suited  for  the  PC/personal  work  station  environment  as 
opposed  to  a  mini-  or  main-frame  time  shared  environment.  The  PC  environment  should 
provide  greater  flexibility  and  freedom  when  implementing  follow-on  tools  for  the  PHI 
programming  language.  Also,  future  compiler  improvements  will  not  have  to  be  concerned 
with  extraneous  interfaces  to  another  system.  Working  with  a  PC  environment  eliminates 
the  need  to  take  into  account  the  effects  the  PHI  environment  will  have  on  another  user  of 
the  system.  The  implementor  is  able  to  work  with  a  system  that  remains  constant  —  a 
known  quantity. 

The  assumed  target  machine  configuration  is  based  on  the  equipment  available  in  the 
Naval  Postgraduate  School's  computer  science  microcomputer  lab.  Each  machine  is 
configured  with  640K  bytes  of  RAM,  one  (most  have  two)  20M  byte  hard  disk  drive,  one 
1.2M  byte  5  inch  floppy  disk  drive,  and  the  8087  math  co-processor;  each  currently 
operates  under  the  MS-DOS6  3.x  operating  system.  These  machines  are  readily  available 
to  all  computer  science  students  at  the  Naval  Postgraduate  School,  and  many  students  own 


5IBM  is  a  registered  trademark  of  Internal  Business  Machines  Corporation. 
6MS-DOS  is  a  registered  trademark  of  Microsoft  Corporation. 
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personal  computers  with  similar  configurations.  It  is  not  necessary  to  utilize  a  hard  disk 
when  executing  the  PHI  compiler. 

E.    CONSTRAINTS 

As  is  the  case  with  most  implementation  theses,  time  was  probably  the  biggest 
constraint  facing  the  authors.  This  involved  making  certain  trade-offs;  e.g.  should  the 
major  effort  be  directed  towards  a  full  implementation  of  PHI  while  concentrating  on  a 
particular  component  of  the  compiler,  or  should  the  major  effort  be  directed  towards  a  full 
implementation  of  the  compiler  while  concentrating  on  a  subset  of  the  PHI  language?  The 
authors  felt  that  the  greatest  benefit  could  be  gained  by  implementing  a  complete  compiler. 
Having  to  actually  face  the  issues  and  problems  associated  with  designing,  implementing, 
and  interfacing  a  full  compiler  implementation  would  be  much  different  than  just  reading 
about  them  in  a  text.  As  a  result,  this  thesis  implements  only  a  subset7  of  PHI. 

Since  PHI  is  an  experimental  language  it  is  still  undergoing  changes  and  revisions. 
Trying  to  modify  and  update  the  compiler  design  with  each  version  proved  to  be  an 
impossibility.  The  authors  were  forced  to  freeze  the  design  based  on  the  language  as  it 
stood  on  07  January  1987.  Any  follow-on  work  will  need  to  update  the  front-end  and 
back-end  of  the  compiler  to  meet  the  requirements  of  these  new  versions  of  PHI.  A 
description  of  the  grammar  as  implemented  and  a  description  of  the  latest  version  of  the 
grammar  may  be  found  in  the  Appendixes. 


7This  subset  is  discussed  in  the  individual  chapters  on  the  front-end  and  back-end. 
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n.    FRONT-END  OF  THE  COMPILER 

The  authors  separated  the  design  of  the  PHI  compiler  into  two  modules,  a  front-end 
and  a  back-end.  These  modules  were  then  further  subdivided  to  produce  the  general  layout 
of  Figure  1.1.  The  authors  believe  this  modularization  simplifies  the  design  and  will  aid  in 
understanding  the  system,  thus  decreasing  future  maintenance  problems. 

The  front-end  of  the  PHI  compiler  is  comprised  of  the  scanner  (lexical  analyzer),  the 
parser  (syntactic  analyzer),  and  their  associated  error  recovery  routines.  Two  possible 
interactions  between  the  lexical  and  syntactic  analyzers  were  considered.  The  first 
incorporates  the  scanner  into  the  parser,  and  tokens  are  produced  by  the  scanner  only  upon 
request  of  the  syntactic  analyzer.  Thus,  this  system  acts  like  a  pipeline.  An  alternate 
method  is  to  allow  the  scanner  to  tokenize  the  entire  source  program,  store  the  tokens  in 
some  data  structure,  and  pass  this  structure  to  the  parser.  [Ref.  3:p.  10] 

For  the  prototype  implementation  of  a  PHI  compiler,  the  authors  based  the  design  on 
the  first  interaction.  Although  the  second  method  is  conceptually  very  easy  to  understand, 
the  authors  think  the  current  implementation  is  clean  and  will  readily  lend  itself  to  future 
enhancements.  Any  input  alphabet  peculiarities  are  restricted  to  the  lexical  analyzer,  and 
this  independence  should  provide  benefits  for  the  next  student(s)  who  work  on  the  PHI 
programming  environment. 

A.    LEXICAL  ANALYSIS  —  THE  SCANNER 

The  PHI  compiler  reads  a  source  file  of  ASCII  text  which  is  fed  to  the  scanner  for 
lexical  analysis.  The  principle  task  of  lexical  analysis  is  to  separate  or  divide  the  source 
program  into  tokens  for  use  during  syntactic  analysis  [Ref.8:p.  84,  Ref.  9:p.  155].  This 
is  accomplished  in  the  PHI  compiler  through  a  character-by-character  examination  of  the 


13 


user's  source  file.  These  characters  are  assembled/grouped  into  the  individual  tokens 
which  represent  terminal  symbols  of  the  PHI  grammar.  Examples  of  some  of  the  terminal 
symbols  are  operators,  identifiers,  keywords,  and  constants.  A  complete  listing  of  the  PHI 
tokens  may  be  found  in  the  header  file  for  the  scanner  in  Appendix  E. 

The  primary  advantage  to  tokenizing  the  source  program  is  that  the  design  of  the 
syntactic  analyzer  needs  to  take  into  account  only  one  type  of  data  unit  —  the  token  [Ref. 
3:p.  7].  This  simplifies  the  design  of  the  parser  because  provisions  do  not  have  to  be 
made  for  handling  white  space  and  comments.  The  scanner  has  already  removed  them. 
Also,  removing  white  space  and  comments  and  utilizing  a  fixed-length  representation  for 
the  tokens  saves  space.  Once  tokenization  is  complete,  the  source  program  can  be 
discarded  and  the  compacted  tokenized  file  can  be  utilized  for  further  analysis. 

In  order  to  correctly  tokenize  the  source  file  there  must  be  some  discrete  means 
available  to  accurately  represent  each  token.  There  are  several  ways  of  describing  tokens. 
One  means  available  is  to  use  a  regular  grammar.  In  this  method  "generative  rules  are 
given  for  producing  the  desired  tokens"  [Ref.  3:p.  142].  An  equivalent,  but  different, 
method  is  to  use  finite-state  acceptors,  FSAs,  to  recognize  tokens.  The  authors  found  it 
easier  to  visualize  this  as  a  recognitive  vice  generative  problem.  For  this  reason  the  various 
tokens  were  modeled  using  FSAs.  An  example  of  an  unsigned  number  recognizer  is 
shown  in  Figure  2. 1 .  The  interested  reader  is  directed  to  Tremblay  and  Sorenson  [Ref. 
3:Chapter  4]  for  an  excellent  introduction  to  the  practice  of  using  FSAs  to  model  tokens. 
The  authors  found  that  utilizing  FSAs  greatiy  simplified  the  design,  coding,  and  debugging 
of  the  lexical  analyzer  —  one  picture  was  worth  a  hundred  lines  of  code. 

The  ideal  grammar  would  allow  each  token  to  be  uniquely  and  unambiguously 
identified.  Once  the  lexical  analyzer  started  on  the  path  of  building  a  token,  it  would  be 
able  to  continue  until  the  end  with  no  backtracking.  Due  to  limitations  with  the  standard 
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Figure  2. 1  Unsigned  Number  Recognizer 
ASCII  character  set,  the  designer  of  PHI  used  multiple  keystrokes,  or  characters,  to 
represent  various  operators  in  the  language8.   This  resulted  in  compound  token  types. 
Also,  as  in  other  programming  languages,  PHI  overloads  certain  operators,  allowing  them 
to  do  double  duty9  by  taking  on  different  context-dependent  meanings. 

The  problem  of  dealing  with  compound  token  types  was  easily  handled  through  the 
use  of  a  single  lookahead  character.  For  example,  upon  finding  the  character  "-",  the 
scanner  looks  ahead  to  the  next  character  to  see  if  it  is  ">"  (  -*)  or  another  "-"  (--).  If  the 
next  character  is  neither  of  these  two,  it  indicates  that  the  token  is  just  the  simple  token  "-". 
Distinguishing  overloaded  operators  was  solved  by  essentially  ignoring  it  in  the  scanner! 
The  authors  took  the  position  this  is  basically  a  syntax  analyzer  problem  and  there  was  no 
reason  to  complicate  the  scanner  by  handling  it.  The  scanner  just  identifies  a  generic  token 
type,  e.g.  SUB_,  and  lets  the  parser  make  the  proper  determination  of  its  true  meaning,e.g. 
SUB_  or  NEG_. 

There  are  several  design  decisions  relating  to  the  lexical  analyzer  worth  noting.  The 
authors,  following  the  example  of  Pascal,  C,  and  other  languages,  took  the  position  that 


°Some  examples  of  this  are  ->  for  — »,  =  for  =  and  <>  for  *. 

^or  example,  +  and  -  can  serve  as  either  an  unary  or  binary  arithmetic  operator. 
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PHI's  keywords10  are  reserved  words  and  may  not  be  redefined  and  used  as  identifiers. 
Alternate  decisions  would  have  been  to  distinguish  keywords  from  identifiers  based  on 
context,  as  PL/I  does,  or  to  precede  them  by  some  special  character,  as  ALGOL  60  and 
ALGOL  68  do  [Ref.  3:p.  91].  PHI  has  a  very  small  set  of  keywords,  smaller  than  Cs, 
and  the  authors  think  that  this  decision  makes  life  easier  for  the  programmer  by  simplifying 
debugging  of  programs.  It  certainly  made  life  easier  for  the  authors. 

PHI's  grammar  makes  no  provisions  for  programmer  comments.  The  authors 
originally  implemented  comments  by  requiring  the  programmer  to  explicitly  indicate  the 
beginning  and  end  of  each  comment  with  a  special  character.  After  scanning  the  special 
character  at  the  beginning  of  the  comment,  the  lexical  analyzer  would  ignore  all  following 
characters  until  the  special  character  was  once  again  found.  Following  conversations  with 
PHI's  designer  this  implementation  was  changed.  Comments  are  now  implemented  the 
same  way  they  are  in  Ada11:  the  comment  terminator  is  the  end-of-line  character.  Not 
only  did  this  simplify  the  recognizer  for  comments,  but  it  also  completely  removed  the 
problem  of  runaway  comments. 

A  name  table  is  used  to  point  to  the  names  of  all  identifiers  and  constants.  A  symbol 
table  was  originally  utilized  but  later  discarded  when  the  authors  realized  the  syntax  of  PHI 
makes  analyzing  an  abstract  syntax  tree  easier  than  analyzing  a  flattened  tree.  The 
information  normally  associated  with  a  symbol  table  is  now  held  in  the  nodes  of  the  tree. 
This  permits  just  the  first  instance  of  each  name  to  be  placed  into  the  name  table.  In  other 
words,  regardless  of  how  many  rimes  and  in  how  many  scopes  the  identifier  X  is  used,  X 
appears  only  once  in  the  name  table.  The  token  returned  to  the  parser  would  indicate  a 


10A  complete  listing  of  PHI  keywords  may  be  found  in  the  header  file  for  the  scanner  in  Appendix  E. 

11  Ada  is  a  trademark  of  the  Ada  Joint  Programming  Office,  Department  of  Defense,  United  States 
Government 
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token  type  of  identifier  and  the  parser  would  then  know  to  dereference  the  pointer  to  find 
the  string  containing  the  actual  name,  X. 

Because  keywords  are  reserved,  each  potential  identifier  must  first  be  compared 
against  the  possible  keywords  prior  to  being  placed  in  the  name  table.  The  authors 
implemented  a  keyword  table  to  simplify  this  process.  Knuth  [Ref.  10:pp.  406-4101  has 
shown  that  a  binary  search  is  the  most  efficient  way  of  searching  an  ordered  table,  using 
only  comparisons.  For  this  reason  the  keyword  table  is  kept  in  alphabetical  order.  The 
lookup,  which  is  at  worst  0(log  n),  is  performed  using  a  binary  search  of  the  keyword 
table. 

In  an  attempt  to  improve  the  efficiency  of  the  name  table,  the  authors  implemented  it  as 
a  hash  table.  McKeeman  [Ref.  ll:pp.  253-301]  experimented  with  six  different  length 
dependent  hash  functions.  He  found  that  the  function  producing  the  best  results  involved 
summing  the  internal  representation  of  the  first  and  last  characters  of  the  variable's  name 
with  its  length  shifted  four  places  to  the  left.  This  was  the  function  utilized  by  the  authors. 
The  possibility  of  collisions  is  reduced  by  choosing  a  prime  number  as  the  table  size. 
However,  since  this  only  reduces,  not  eliminates,  the  possibility  of  two  or  more  names 
hashing  to  the  same  value;  the  authors  had  to  make  provisions  for  handling  collisions. 

A  variant  of  the  chaining  method  of  collision-resolution  was  chosen.  In  PHI's 
implementation,  each  of  the  name  table  slots/buckets  holds  a  data  structure  that  can  contain 
both  the  name  of  the  variable  and  a  pointer  to  another  structure  of  the  same  type.  So  each 
hashed  value  points  to  a  linked  list  of  names.  This  method  offers  the  advantage  of 
providing  better  performance  than  linear  probing  [Ref.  12:p.  89],  is  conceptually  easy  to 
visualize/work  with,  and  also  solves  the  problem  of  possibly  overflowing  the  hash  table.  It 
does  require  slightly  more  memory  to  implement,  but  the  authors  determined  that  the 
benefits  of  this  method  far  outweighed  the  slight  increase  in  storage  requirements.  [Ref. 
12:pp.  83-93] 
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B.    SYNTACTIC  ANALYSIS  —  THE  PARSER 

The  purpose  of  the  parser  is  twofold:  1)  to  determine  if  the  program,  as  represented 
by  the  output  from  the  scanner,  is  syntactically  correct;  2)  to  impose  a  hierarchical  structure 
on  the  token  stream,  fitting  it  into  the  abstract  syntax  tree  which  is  the  output  of  the  parser 
[Ref.  8:pp.  7-8,  Ref.  9:p.  7],  Traditionally,  these  tasks  are  done  by  either  a  top-down  or 
bottom-up  methodology  [Ref.  8:p.  41].  Both  methodologies  use  the  tokens  generated 
through  lexical  analysis. 

The  terminology  top-down  refers  to  the  order  in  which  the  nodes  of  the  parse  tree  are 
constructed.  Top-down  parsing  starts  from  the  root  of  the  tree  and  proceeds  downward 
towards  the  terminal  symbols  at  the  leaves.  The  parse  tree  is  constructed  from  the  top  to 
the  bottom  by  applying  productions  of  the  grammar  to  generate  strings  of  terminals  and 
nonterminals.  On  the  other  hand,  bottom-up  methodologies  start  from  the  terminal 
symbols  at  the  leaves  and  proceed  upwards  to  the  root.  The  parse  tree  is  constructed  from 
the  bottom  to  the  top  by  applying  reductions  of  the  grammar  to  generate  single  nonterminals 
from  strings  of  terminals  and  nonterminals.  [Ref.  8:pp.  40-41,  Ref.  9:pp.   134-136] 

It  is  generally  agreed  that  the  popularity  of  top-down  parsing  techniques  is  "due  to  the 
fact  that  efficient  parsers  can  be  constructed  more  easily  by  hand".  [Ref.  8:p.  41]  The 
authors  can  attest  to  the  fact  that  the  concept  of  top-down  parsing  is  very  easy  to  grasp. 
When  parsing  PHI,  it  is  natural  to  begin  with  the  start  symbol  of  the  grammar, 
BLOCKBODY,  and  work  forward  from  there  to  analyze  the  token  stream.  So,  partially 
because  of  its  efficiency,  but  primarily  because  of  its  ease  of  understanding  and  use,  the 
authors  chose  the  top-down  methodology  of  recursive-descent  parsing  to  design  and 
implement  the  syntactic  analyzer. 

In  recursive-descent  parsers,  separate  procedures/functions  are  written  to  recognize 
each  nonterminal  of  the  grammar  [Ref.  3:pp.  219-220].  This  technique  gets  its  distinctive 
name  "because  nonterminals  can  appear  in  the  right-hand  sides  of  each  other's 
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productions,  the  procedures  for  recognizing  nonterminals  are  recursive."  [Ref.9:p.  150] 
To  state  it  more  clearly,  the  function  to  recognize  nonterminal  'A'  could  end  up  calling  itself 
recursively  if  either  1)  'A'  appears  on  the  right-hand  side  of  the  production  describing  'A' 
itself,  or  2)  'A'  appears  on  the  right-hand  side  of  the  production  describing  another 
nonterminal  'B'  and  'B'  appears  on  the  right-hand  side  of  the  production  describing  'A'. 
Regardless  of  how  one  looks  at  the  nature  of  the  technique,  one  usually  identifies  a  stack 
with  recursion.  What  made  this  technique  so  easy  to  implement  was  that  the  authors  were 
able  to  use  C's  underlaying  mechanism  for  handling  recursive  functions.  The  authors  did 
not  have  to  explicitly  maintain  a  stack  of  symbols  for  each  function  call;  instead,  the 
information  was  implicit  in  the  stack  of  activation  records  resulting  from  each  function  call. 
Top-down  parsing  techniques,  especially  recursive  descent,  offer  straightforward 
means  of  implementing  a  syntactic  analyzer.  However,  these  techniques  are  applicable 
only  to  a  subset  of  the  context-free  grammars  and  it  is  essential  that  all  left  recursion  be 
eliminated  from  the  grammar  [Ref.  3:p.  211].  In  other  words,  there  must  not  exist  any 
productions  describing  nonterminal  'A'  with  'A'  appearing  as  the  first  element  on  the 
right-hand  side  of  the  production.  Obviously,  if  this  situation  existed,  it  would  be  possible 
to  present  the  parser  with  strings  to  parse  that  would  cause  it  to  enter  "an  infinite  loop  of 
production  applications"  [Ref.  3:p.  211],  never  to  be  heard  from  again.  The  PHI 
production  QUALEXP  =  QUALEXP  WHERE  AUXDEFS  is  an  example  of  this  type  of  string. 
The  parser  would  hang  up  looking  for  QUALEXP  and  would  never  leave  this  loop  until  the 
machine  ran  out  of  memory  stacking  activation  records.  In  order  to  employ  top-down 
parsing  techniques  with  PHI  the  authors  rewrote  the  PHI  grammar  to  be  right-recursive12. 
However,  as  shown  below,  even  the  new  grammar  does  not  lend  itself  to  "pure"  recursive 
descent  parsing  techniques. 


12The  right  recursive  syntax  of  PHI  may  be  found  in  Appendix  D 
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From  the  compiler  writer's  point  of  view  the  ideal  grammar  would  allow  the  correct 
production  rule  to  be  applied  in  every  step  of  the  parsing  process.  Constructing  the  parse 
tree  would  then  proceed  in  a  completely  deterministic  manner.  When  this  is  not  possible, 
there  are  two  basic  parser  design  methods  for  dealing  with  nondeterminism  in  the  grammar 
[Ref.  9:pp.  151-152].  In  the  backtracking  method,  which  is  generally  not  applicable  to 
recursive-descent  techniques,  the  parser  picks  an  arbitrary  production  and  continues  with 
the  parse  [Ref.  9:p.  151].  If  the  parse  is  successful  it  is  assumed  that  the  correct 
production  was  chosen.  However,  if  an  error  is  later  discovered,  the  parser  backtracks  to 
the  last  choice,  a  new  production  is  chosen,  and  the  parser  presses  forward  again.  This 
process  continues  until  either  the  parse  is  successful  or  the  parser  runs  out  of  possible 
productions  to  chose  from.  The  second  method  requires  a  modification  to  the  grammar 
which  results  in  a  deterministic  parser:  the  grammar  is  rewritten  using  a  process  called  left 
factoring  to  avoid  choices  among  nonterminals  [Ref.  9:p.  151]. 

For  the  most  part,  the  design  of  PHI  is  conducive  to  recursive  descent  parsing 
techniques.  There  are,  however,  several  productions  where  this  is  not  so.  The  result  was 
that  a  degree  of  nondeterminism  arose  in  the  parser  design.  The  authors  attempted  to  solve 
this  problem  through  a  combination  of  left  factoring  and  the  employment  of  a  simple  single 
token  look-ahead.  This  solution  worked  for  all  but  the  two  productions  described  below. 
In  one  case  a  two  token  look-ahead  was  employed  and  backtracking  was  used  tn  the  other. 
This  is  not  to  say  that  the  authors  are  absolutely  certain  that  PHI  is  not  an  LL(1)  grammar 
or  that  backtracking  had  to  be  used.  These  solutions  were  used  because  they  solved  the 
problem  at  hand. 

A  two  token  look-ahead  was  used  for  the  production13  ARGBINDING  =  [  QUALEXP  OP 
].  When  the  token  '['  is  found,  a  flag  is  set  to  indicate  that  an  ARGBINDING  is  being 
parsed.  The  first  look-ahead  token  is  utilized  when  parsing  the  QUALEXP  part.  QUALEXP, 


13A  complete  description  of  the  PHI  grammar  may  be  found  in  the  Appendices 
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for  example,  may  parse  as  TERM,  which  in  turn  may  parse  as  either  FACTOR  or 
FACTOR*TERM.  After  succeeding  on  FACTOR,  a  look-ahead  is  employed  to  look  for  the 
MULOP,  *,  to  see  if  a  recursive  search  for  another  TERM  should  be  initiated.  This 
methodology  works  as  long  as  QUALEXP  was  not  called  from  ARGBINDING.  If  it  was 
called  from  ARGBINDING,  argbinding  flag  set,  the  operator  *  could  be  the  trailing  operator 
in  the  ARGBINDING  production  and  not  part  of  the  TERM  production.  In  order  to  make  this 
determination,  an  additional  look-ahead  is  utilized  to  look  for  the  token  ']'•  If  T  is  found 
the  QUALEXP  production  is  terminated,  e.g.,  term  does  not  recursively  call  itself  again,  and 
the  ARGBINDING  production  is  allowed  to  proceed  to  completion. 

Backtracking  was  utilized  when  parsing  productions  of  ACTUAL:  ACTUAL  = 
COMPOUND  and  ACTUAL  =  DENOTATION  =  FORMALS  l->  ACTUAL.  Legitimate  PHI 
sentential  forms  produced  by  the  production  FORMALS  =  (  FORMALS"1")  are  proper  subsets 
of  the  sentential  forms  produced  by  the  production  COMPOUND  =  (  ELEMENTS  ),  excluding 
the  empty  compound  statement.  Since  any  number  of  identifiers  may  appear  between  the 
parentheses,  it  is  not  practical  during  the  parse  to  utilize  look-ahead  to  determine  the 
presence  of  the  token  "|->".  In  effect,  the  parser  first  realizes  it  was  parsing  a 
DENOTATION  when  it  finds  "|->".  This  problem  was  solved  by  designing  the  parser  to 
apply  first  the  compound  production  when  presented  with  this  choice.  If  "|->"  is  later 
found,  the  parser  then  backtracks14  to  the  FORMALS  production.  The  normal  costs 
associated  with  backtracking  were  not  evident  in  this  isolated  case.  As  described  below, 
space  trade-offs  had  previously  been  made  and  the  parser  was  already  working  with  an 
abstract  syntax  tree.  The  root  to  the  subtree  containing  the  previously  parsed  compound 
was  simply  passed  to  the  FORMALS  production  to  insure  that  the  string  could  have  been 


14A  purist  would  say  that  this  instance  of  backtracking  means  that  the  PHI  compiler  does  not  in  fact 
employ  a  recursive-descent  parser. 
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produced  by  FORMALS.  After  ascertaining  FORMALS,  the  parser  now  continues  the  parse 
using  the  DENOTATION  production. 

The  production  QUALEXP  =  QUALEXP  WHERE  AUXDEFS  required  a  deviation  from 
pure  recursive  descent  parsing.  The  semantics  of  this  production  are  such  that  a  terminal 
(e.g.,  an  identifier)  may  be  used  prior  to  its  definition.  In  itself,  this  does  not  present  a 
major  problem  for  the  compiler  writer.  However,  this  construct  also  changes  the  scope  of 
the  identifier  since  the  inner-most  scope,  in  the  form  of  the  QUALEXP,  is  parsed  first  and 
the  parser  then  works  its  way  to  the  outer-most  scopes,  the  AUXDEFS.  This  problem  is 
analogous  to  that  of  mutual  recursion  in  Pascal,  without  the  benefit  of  the  forward 
declaration  [Ref.  4:p.  213]. 

Originally,  the  parser  was  designed  to  output  the  parse  tree  in  flattened  form, 
essentially  a  post-order  walk  of  the  tree.  This  design  implemented  traditional  symbol-table 
management  routines.  However,  after  obtaining  a  clearer  understanding  of  the  semantics 
involved  with  the  problems  mentioned  earlier,  notably  the  production  QUALEXP  = 
QUALEXP  WHERE  AUXDEFS,  the  authors  realized  a  traditional  symbol-table  would  be  too 
inefficient.  Management  of  the  table  would  take  an  inordinate  amount  of  assets  and  be  too 
unwieldy  to  work  with.  The  authors  solved  this  problem  by  maintaining  the  status  of  the 
parse  in  an  abstract  syntax  tree  so  the  output  from  the  parser  is  now  in  tree  form.  This 
permits  information  originally  held  in  the  symbol-table  to  be  maintained  in  the  tree  itself. 
The  parser  is  able  to  analyze  the  source  program  by  walking  the  tree  and  decorating  the 
nodes  with  required  information.  Maintaining  a  binary  tree  in  memory  does  require  more 
space,  but  this  is  insignificant  when  compared  with  the  benefits. 

Interestingly,  maintaining  the  parse  in  tree  form  presented  several  additional  benefits. 
The  solution  to  the  aforementioned  problem  of  distinguishing  between  COMPOUND  and 
DENOTATION  became  trivial  because  it  was  now  simply  a  matter  of  returning  to  the 
appropriate  subroot  and  rewalking  the  tree.  Also,  working  with  a  binary  tree  permitted  the 
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authors  to  perform  a  modicum  of  optimization  in  the  parser.    It  becomes  relatively 
straightforward  to  perform  compaction  on  an  actual  tree. 

The  authors  think  that  this  design  offers  maximum  potential  for  future  enhancements 
of  the  PHI  programming  environment.  One  possibility  would  be  to  use  this  front-end  to 
drive  a  PHI  interpreter.  Modularization  of  the  front-end  in  this  manner  simplifies 
functional  understanding  of  the  front-end  and  should  lead  to  increased  ease  of  maintenance 
and  portability.  To  demonstrate  portability,  the  authors  recompiled  the  front-end  and 
executed  it  on  a  68000  based  processor.  This  was  accomplished  with  no  modifications  to 
the  source  program,  just  replacement  of  C  run-time  header  files  for  the  new  target  machine. 

C.    ERROR  HANDLING 

Tremblay  and  Sorenson  [Ref.  3:p.   183]  classify  error  responses  into  three  categories: 

I.       Unacceptable  responses 

1 .  Incorrect  responses  (error  not  reported) 

a.  Compiler  crashes 

b.  Compiler  loops  indefinitely 

c.  Compiler  continues,  producing  incorrect  object  program 

2.  Correct  (but  nearly  useless) 

a.      Compiler  reports  first  error  and  then  halts 
II.        Acceptable  responses 

1 .  Possible  responses 

a.  Compiler  reports  error  and  recovers,  continuing  to  find  later  errors  if  they  exist 

b.  Compiler  reports  the  error  and  repairs  it,  continuing  the  translation  and  producing  a 
valid  object  program 

2.  Impossible  with  current  techniques 

a.      Compiler  corrects  error  and  produces  an  object  program  which  is  the  translation  of 
what  the  programmer  intended  to  write 

In  the  prototype  PHI  compiler,  the  authors  have  implemented  a  limited  form  of  error 
recovery.  The  primary  benefit  of  error  recovery  is  to  "prolong  the  compilation  life  of  the 
program  as  long  as  possible  before  the  compiler  gives  up  on  the  source  program".  [Ref. 
3:p.  11]  This  allows  the  maximum  number  errors  to  be  discovered  per  compilation, 
shortening  the  edit,  compile,  debug  cycle  inherent  to  writing  computer  programs. 

The  authors  analyzed  the  intended  environment  and  use  of  the  PHI  compiler  and 
decided  that  lexical  analysis  and  syntactic  analysis  were  the  most  likely  source  of  errors. 
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Lexical  errors  basically  involve  invalid  characters  or  incorrect  tokens.  Common  examples 
of  these  types  of  errors  are  unrecognized  words,  misspelled  identifiers/keywords,  or  illegal 
characters.  Syntactic  errors  relate  to  incorrect  structure  of  the  program.  These  errors  arise 
when  the  programmer  failed  to  follow  the  rules,  productions,  of  the  grammar.  The  form  of 
the  program  is  wrong.  [Ref.  9:p.  226,  Ref.  3:p.   185] 

One  thing  the  error  handler  should  not  do  is  exacerbate  the  situation  by  reporting 
bogus  errors  or  executing  an  erroneous  program.  To  insure  erroneous  programs  are  not 
executed,  the  authors  inhibited  object  file  production  if  any  errors  were  discovered.  The 
authors  do  not  believe  the  compiler  should  allow  code  generation  to  continue,  or  even 
begin,  if  the  source  program  has  errors.  Often  times  one  error  leads  to  an  avalanche  of 
errors  being  reported  and  this  is  extremely  annoying  to  the  programmer.  The  authors 
attempted  to  minimize  this  situation,  but  found  it  impossible  to  eliminate  completely 
because  some  errors  feed  on  others.  To  insure  the  programmer  would  not  become 
overwhelmed  with  error  messages,  the  authors  terminate  the  compilation  after  10  errors. 
Also,  for  programmer  convenience,  actual  error  messages  are  outputted  instead  of  error 
codes.  The  authors  saw  no  justification  in  using  a  cryptic  code  when  a  plain  language 
message  served  much  better.  Since  the  authors  anticipate  students  in  functional 
programming  classes  to  be  primary  users  of  the  PHI  compiler,  error  messages  have  their 
basis  in  the  productions  describing  the  PHI  language.  It  is  assumed  that  users  of  the  PHI 
compiler  have  an  understanding  of  PHI's  syntax. 
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III.    BACK-END  OF  THE  COMPILER 

A.  OVERVIEW 

The  back-end  of  the  compiler  consists  of  the  semantic  checker  and  code  generator. 
Semantic  checking  and  code  generation  are  completed  in  one  pass,  and  the  output  is  a 
sequence  of  bytes,  held  in  memory,  which  correspond  to  ASCII  characters.  These 
characters  are  then  written  to  a  text  file,  which  the  assembler  uses  to  output  an  object  file. 
This  output  is  linked  to  the  appropriate  run-time  routines  to  make  a  usable  program.  For 
the  current  implementation,  a  RASM86  assembler  and  LINK8615  linker  are  used. 

B.  RUN-TIME  ORGANIZATION 

Since  PHI  is  a  structured  language  with  scoping  and  function  calls,  it  lends  itself  to  a 
stack-oriented  run-time  architecture.  The  stack  is  set  up  to  accomplish  two  tasks:  1)  to 
hold  pointers  to  the  current  operands,  and  2)  to  hold  activation  records  for  functions 
currentiy  in  use.  Both  of  these  tasks  are  described  below. 

There  is  a  64  kilobytes  limit  on  memory  used  while  a  program  is  running.  This 
limitation  is  imposed  because  the  memory  is  addressed  as  an  offset  from  a  base  address, 
and  the  maximum  offset  is  64K.  This  space  is  competed  for  by  the  stack,  current 
variables,  and  constants  (see  Figure  3.1).  The  stack  grows  from  the  top  of  this  space 
down,  and  the  variable  space  grows  from  the  base  of  this  space  up,  preventing  wastage  by 
either  component.  Because  PHI  is  a  functional  language,  a  value  is  returned  from  each 
operation,  and  a  pointer  to  this  value  is  placed  at  the  top  of  the  stack.  The  returned  value  is 
placed  in  the  lowest  available  space  in  the  part  of  memory  assigned  to  variables  and 
constants.  A  heap  allocation  method  is  not  currently  used  because  1)  all  data  types 
currently  implemented  use  only  one  word  of  memory,  and  2)  there  is  no  fragmentation  of 
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memory  because  all  types  are  currently  static.  If  the  next  operation  is  a  binary  operation,  a 
pointer  to  the  second  operand  is  placed  on  the  stack,  and  the  operation  takes  place  using  the 
two  topmost  pointers.  The  result  is  placed  in  memory,  and  the  process  begins  afresh  with 
new  operands.  If  the  next  operation  is  unary  (such  as  the  negation  operation),  no  change 
to  the  stack  takes  place  and  the  variable  in  memory  is  altered  as  the  program  directs. 


Address 

64Kb 
0  Kb 

)        Stack 
-4-        TOS 

^^>     Values 
/        (Variables  and 
Constants) 

Figure  3.1 
Memory  Organization 

If  the  second  operand  of  an  operation  is  to  be  the  result  of  a  function  call  (e.g.,  "2  * 
f(x)"),  an  activation  record  is  placed  on  top  of  the  pointer  to  the  first  operand  and  the 
function's  value  is  calculated.  Then,  the  activation  record  is  deleted  and  a  pointer  to  the 
function  result  is  saved  and  placed  at  the  top  of  the  stack. 
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Static  Link 

Static  Nesting  Level 

Pointer  to  Value  Space 

Figure  3.2 
Activation  Record 

The  activation  record  itself,  Figure  3.2,  contains  three  parts:  the  static  link,  the  static 
nesting  level,  and  a  pointer  to  the  address  in  memory  where  the  function's  first  variable  is 
stored.  The  static  link  is  a  one-word  pointer  which  points  to  the  static  nesting  level  space 
of  the  previous  activation  record,  and  is  used  to  traverse  the  stack  from  activation  record  to 
activation  record,  i.e.  a  static  chain.  [Ref.  4:p.  77].  The  static  nesting  level  and  the  pointer 
to  the  base  of  the  storage  space  for  a  scope's  values  are  used  to  access  variables  and 
constants.  In  this  design,  a  two-tuple  (B,  L)  is  associated  with  each  variable.  In  this  two- 
tuple,  B  represents  the  static  nesting  level  and  L  is  the  offset  within  that  level.  By 
following  the  static  chain  for  (current  nesting  level  -  target  nesting  level)  links,  the 
activation  record  of  the  scope  of  the  target  value  can  be  accessed.  Then,  the  address  of  the 
variable  is  calculated  by  adding  L  to  the  low  address  of  the  scope's  variables.  An  alternate 
method  would  have  been  to  store  the  values  directly  in  the  stack  between  or  within 
activation  records.  However,  this  is  a  messy  process  when  dealing  with  dynamic  data 
structures  such  as  sequences.  Additionally,  it  is  conceptually  easier  to  divide  the  stack  and 
the  variables. 

Functions  are  implemented  as  calls  to  assembly  language  subroutines,  with  pointers  to 
the  arguments  placed  on  the  stack  before  calling  the  routine.  Using  this  scheme,  and  noting 
the  fact  that  PHI  cannot  have  side  effects,  the  implementation  of  recursion  is 
straightforward.  Whenever  a  function  is  called,  its  activation  record  is  placed  on  the  stack 
and  pointers  to  its  arguments  are  placed  on  top  of  the  activation  record.  If  the  function  is 
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recursive,  the  assembly  language  subroutine  simply  calls  itself  until  the  base  of  its 
recursion  is  reached  or  until  stack  overflow  is  reached.  Figure  3.3  shows  an  example  of  a 
series  of  activation  records  called  by  a  program  with  a  recursive  function.  Note  that  the 
data  definition  ("answer")  has  no  arguments  and  simply  calls  the  factorial  function.  The 
factorial  function,  on  the  other  hand,  has  an  argument  and  it  uses  that  argument  as  an 
operand.  So,  a  pointer  to  that  value  is  put  on  the  stack  and  the  next  operand,  fac  (n  -  1),  is 
put  on  the  stack  as  an  activation  record.  When  fac  (n  -  1)  is  evaluated,  a  pointer  to  its 
return  value  is  placed  on  the  stack.  This  cycle  of  evaluation,  pop  activation  record, 
evaluation  will  continue  until  the  data  definition  "answer"  is  evaluated. 


Address 

64000 
Base  of 

64000 

^             Answer 
?■  Activation  Record 

J         (no  actuals) 

Fac  (5) 
■^Activation  Record 

Fac  (4) 
Activation  Record 

J,           Fac  (3) 

J     Activation  Record 

0 

0 

Value  Space 

61998 

1 

1 

t 

Ptr  to  Actual 

Ptr  to  5 

63997 

2 

3 

I         : 

Ptr  to  Actual 

Ptr  to  4 

63992 

3 

0  Kb 

answer  where  answer  =  fac(5)  where 
fac(n)  ==  if  n  ==  0  then  1 

else  n  *  fac(n-l)    endif 

Figure  3.3 
Factorial  Program  and  Activation  Records 

As  an  example  of  the  code  generated  for  function  calls  and  recursion,  the  following 
PHI  program  fragment  is  used  :  C  (n)  ==  if  n  =  0  then  1  else  C  (n  -  1)  *  n  endif. 
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This,  of  course,  simply  calculates  the  factorial  of  the  integer  n.    Figure  3.4  is  the 
listing  of  the  assembly  language  segment  which  is  generated  from  this  fragment. 


Address/Machine  Code 

Assembly  Language 
0150  jmpalOOOO 

0103E94A00 

alOOOl: 

0106  B90000 

mov  cx,0 

0109  E80000 

E 

call  Lformal 

010C  B80000 

mov  ax,0 

010FE80000 

E 

call  iputvalue 

0112E80000 

E 

calliequ 

0115E80000 

E 

call  igetvalue 

0118  3D0100 

cmp  ax,l 

01  IB  7509 

0126 

jne  al0003 

011DB80100 

mov  ax,l 

0120  E80000 

E 

call  iputvalue 

0123  E92600 

014C 

jmp  al0002 
al0003: 

0126  B90000 

mov  cx,0 

0129  E80000 

E 

call  Lformal 

012CB90000 

mov  cx,0 

012F  E80000 

E 

call  Lformal 

0132B80100 

mov  ax,l 

0135E80OOO 

E 

call  iputvalue 

0138E80OOO 

E 

call  isub 

013BE80OOO 

E 

call  ppop 

013E51 

push  ex 

013F57 

push  di 

0140BB0100 

mov  bx,  1 

0143  E80000 

E 

call  i  mov 

0146  E8BDFF 

0106 

callalOOOl 

0149  E80000 

E 

call  imult 
al0002: 

014C  E80000 

E 

call  del_scope 

014FC3 

ret 
alOOOO: 

Figure  3.4 
Assembly  Language  Output  from  Factoral  Program 

The  label  "alOOOl"  at  address  0103  is  the  label  of  the  subroutine  which  returns  the 

factorial.  When  it  is  called,  pointers  to  the  values  of  the  arguments  are  placed  on  the  stack. 

If  the  subroutine  is  called  before  the  base  of  the  recursion  is  reached,  a  jump  is  made  to 

label  a  10003.  Then,  the  new  actual  value  (n  -  1)  is  calculated  and  placed  in  the  low  part  of 

memory,  a  pointer  to  the  value  is  pu^  on  the  stack,  and  the  values  are  prepared  for  calling 


29 


by  the  next  subroutine  (lines  0126  to  0143).  The  factorial  subroutine  is  then  called  again. 
This  process  continues  until  the  base  of  the  recursion  is  reached;  in  this  case  a  pointer  to  the 
integer  value  is  put  at  the  top  of  the  stack  (line  01  ID),  and  a  jump  is  made  to  label  a  10002. 
Here,  the  subroutine  "del_scope"  tears  down  the  activation  record  on  the  stack  and  puts  a 
pointer  to  the  result  of  the  function  at  the  top  of  the  stack.  Clearly,  recursion  in  the  PHI 
program  can  be  implemented  by  a  parallel  recursion  in  the  assembly  language  output  of  the 
compiler. 

Another  feature  of  the  output  code  shown  in  Figure  3.4  is  that  there  is  an  unconditional 
jump  around  the  function  (lines  0103  and  014F).  This  is  a  result  of  the  decision  to  output 
inline  code  in  spite  of  the  fact  that  functions  can  be  called  at  random.  There  are  both  space 
and  time  penalties  to  be  paid  for  these  jumps,  especially  since  each  function  must  have  a 
jump  and  label  instruction  bracketing  it.  However,  the  ultimate  effect  of  all  these  jumps  is 
to  get  to  the  label  at  the  bottom  of  the  program.  The  result  is  that  all  but  one  jump/label  pair 
could  be  eliminated  by  an  optimizer,  making  the  penalty  trivial.  Another  solution 
considered  was  to  generate  code  for  functions  and  the  "main"  program  separately,  then 
combine  the  two  when  printing  the  output  from  the  code  generator.  This  was  not  done  for 
reasons  put  forth  in  the  section  that  describes  the  semantic  analyzer. 

Variable  and  constant  storage  is  word  oriented  rather  than  byte  oriented  to  take 
advantage  of  the  8086  processor's  16  bit  capability.  Integers  and  naturals  are  both 
represented  as  single  words,  and  booleans  are  represented  as  integers,  either  1  or  0.  While 
this  boolean  representation  is  somewhat  wasteful  in  terms  of  memory  space,  it  allows  for  a 
great  deal  of  overlapping  in  certain  subroutines  used  in  function  calling  and  comparisons. 
It  is  planned  to  represent  real  numbers  with  two  words  of  memory,  and  sequences  using 
linked  lists.  Neither  of  these  types  have  been  fully  implemented;  however,  there  are 
provisions  in  the  compiler  for  adding  these  features  at  a  later  date. 
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There  is  currently  no  dynamic  allocation  of  registers.  Some  registers  are  used  for 
specific  purposes;  for  instance,  the  SI  register  is  used  to  mark  the  top  of  the  program  stack, 
and  of  course  the  BP  and  SP  registers  are  used  to  manage  the  machine's  stack.  In  general, 
arithmetic  processes  take  place  in  the  AX  register,  using  other  general  registers  as 
auxiliaries  as  needed.  When  variable  space  is  needed,  the  highest  unused  address  space  is 
allocated  and,  when  a  function  is  finished,  only  the  result  is  saved  in  storage;  all  other  value 
spaces  are  returned  for  use  by  the  program. 

Error  handling  is  probably  the  simplest  part  of  the  run-time  routines.  Any  run  time 
error  such  as  overflow  or  division  by  zero  errors  will  result  in  an  appropriate  error  message 
to  the  user  (see  Appendix  O  for  a  full  listing  of  error  messages).  Then,  program  execution 
will  terminate  and  control  is  returned  to  the  operating  system. 

C.    SEMANTIC  CHECKING  and  CODE  GENERATION 

The  PHI  compiler  utilizes  the  recursive  descent  technique  to  perform  semantic 
checking  and  code  generation  in  one  traversal  of  the  parser  tree.  In  most  cases,  tree  nodes 
are  filtered  through  the  semcheck  function,  which  calls  various  procedures  based  on  the 
name  of  the  node.  These  procedures,  in  turn,  call  semcheck  for  each  of  their  children, 
and  the  process  is  repeated  until  the  leaves  of  the  tree  are  reached.  The  function  semcheck 
then  returns  a  type  (e.g.,  integer,  real,  boolean),  which  the  parent  node  uses  to  determine 
the  semantic  correctness  of  its  subtree.  With  the  information  returned  from  the  semcheck 
function,  the  parent  procedure  can  do  one  of  three  things:  return  a  type,  convert  one  node 
to  a  different  type,  or  declare  an  error  condition. 

Concurrent  with  semantic  checking,  code  is  generated.  As  noted  above,  this  is 
assembly  language  code  written  to  a  buffer  in  memory.  If  an  error  condition  is  declared, 
however,  a  flag  is  set  and  code  generation  ends.  Semantic  checking  will  then  continue  until 
the  tree  is  completely  traversed  or  ten  errors  are  accumulated;  then,  the  semantic  checking 
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process  terminates.  Unlike  the  parser,  the  semantic  checker  makes  no  attempt  at  error 
recovery;  top-down  checking  simply  continues  normally  from  where  the  error  was 
detected. 

Top-down  semantic  checking  results  in  a  neat,  trim  package  for  the  back  end  of  the 
compiler.  Unfortunately,  there  are  some  problems  that  pure  top-down  checking  will  not 
solve.  For  instance,  determining  if  there  is  a  one-to— one  match  between  formals  and 
actuals  for  a  given  function  involves  some  detours  from  top-down  checking,  as  explained 
below. 

The  scoping  rules  of  PHI  provided  the  largest  challenge  to  writing  the  semantic 
checker.  One  solution  is  a  multiplicity  of  stacks.  The  size  of  these  stacks  depends  upon 
the  number  of  its  constituents  visible  at  any  one  time.  Usually,  the  proper  match  for  an 
item  is  the  one  found  closest  to  the  top  of  the  stack.  However,  because  of  the  semantics  of 
the  "and"  construct,  checks  against  the  variable-stack  do  not  always  follow  this 
convention. 

There  are  four  stacks  used  by  the  semantic  checker:  the  type- stack,  the  variable-stack, 
the  definition-stack,  and  the  and-stack.  All  but  the  type-stack  are  implemented  as  linked 
lists.  This  implementation  sheds  the  disadvantage  of  static  length  arrays  at  the  cost  of  a 
slight  increase  in  memory  and  temporal  resources.  The  type-stack  uses  a  fixed-length 
array  of  300  entries  because  1)  the  basic  types  of  real,  boolean,  integer,  natural,  and  trivial 
will  be  accessed  most  frequently,  because  they  are  the  building  blocks  of  every  type  and 
sequence,  and  because  they  can  be  more  easily  accessed  from  an  array  than  from  a  linked 
list,  2)  a  list  of  300  type  entries  should  not  impose  an  extreme  burden  on  the  programmer, 
and  3)  the  planned  implementation  of  sequences  will  be  more  straightforward  if  the 
type-stack  is  an  array. 
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Type  Name 

#  of  Bytes 

Link  to  Next  Type 

Figure  3.5 
Type-Stack  Entry 

The  type-stack,  Figure  3.5,  is  meant  to  hold  both  the  basic  type  definitions  and  user 
defined  type  definitions.  This  stack  holds  both  the  name  of  the  type  and  the  number  of 
bytes  needed  in  memory  to  implement  the  type.  At  compiler  initialization,  it  contains  the 
five  basic  types  and  user  defined  types  are  added  as  they  are  encountered.  The  begin-end 
construct  of  the  language  (not  implemented  yet)  allows  declared  types  to  be  visible  over  a 
specified  range.  It  is  planned  to  implement  this  construct  by  setting  a  pointer  to  the  top  of 
the  stack  upon  encountering  the  begin  node  and  then  popping  the  stack  to  that  point  after 
both  of  the  node's  subtrees  have  been  checked. 


Variable  Type 

Formal  Flag 

Node  Pointer 

Link  to  Next  Entry 

Figure  3.6 
Variable-Stack  Entry 

The  variable-stack,  Figure  3.6,  holds  all  of  the  variables,  including  function  names, 
currently  seen  by  the  semantic  checker.  Each  entry  holds  a  pointer  to  the  hash  table 
containing  labels,  a  type,  a  pointer  to  the  tree  node  defining  it,  and  a  flag  to  designate 
whether  or  not  it  is  a  formal.  Whenever  a  variable  name  is  encountered  and  the  name  is  not 
a  call  to  a  function  and  not  a  data  definition,  it  is  put  into  the  variable  stack.  Then,  when  a 
scope  is  exited,  the  variables  local  to  that  scope  are  dropped  from  the  stack.  For  example, 
after  a  function  is  defined,  all  of  its  formals  are  popped  from  the  stack. 
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Definition  Type 

Formals 
Pointer 

Tree  Node  Pointer 

Link  to  Next  Entry 

Figure  3.7 
Definitions  Stack  Entry 

The  definitions-stack,  Figure  3.7,  contains  all  of  the  function  and  variable  definitions 
visible  in  a  given  scope;  e.g.,  the  declaration  C  :  SR  *  $Z  ->  SB  would  put  the  definition  C 
into  the  definition-stack.  This  entry  would  contain  the  type  of  C's  return  value  (Boolean), 
a  pointer  to  the  tree  node  that  contains  C,  and  a  pointer  to  a  linked  list  which  contains  its 
argument  types  (Real  and  Integer).  This  last  field  will  be  null  if  the  declaration  is  a  data 
definition.  This  stack  grows  and  shrinks  in  the  same  way  as  the  type  stack. 

The  authors  considered  combining  the  definitions-stack  and  the  variable-stack  because 
of  the  similarity  between  their  fields.  In  fact,  one  of  the  primitive  implementations  was 
designed  in  this  way.  However,  this  slowed  down  the  search  for  both  definitions  and 
variables  considerably,  and  the  overhead  needed  to  implement  these  two  as  separate  stacks 
is  small:  three  extra  functions  and  one  extra  pointer. 

The  need  for  the  and-stack  is  derived  from  the  scoping  rules  imposed  by  the  AND 
construct.  This  construct  allows  a  variable  to  be  referenced  before  it  is  declared  without  the 
benefit  of  Pascal's  forward  declaration  or  equivalent.  This  is  true  of  other  constructs  in 
PHI  such  as  the  WHERE  construct.  However,  the  AND  construct  cannot  be  parsed  in  such 
a  way  that  the  semantic  checker  can  see  all  variables  before  they  are  used,  because  either 
subtree  of  the  AND  statement  can  define  variables  used  by  the  other  subtree.  So,  a  program 
such  as  the  one  depicted  in  Figure  3.8  needs  a  vehicle  by  which  it  can  detect  that  the 
variable  d  is  defined  later  in  the  program.  The  and-stack  is  such  a  vehicle. 
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Figure  3.8 
Tree  With  Forward  Variables 

When  the  semantic  checker  reaches  the  AUXAND  node,  Figure  3.8,  a  flag  is  set  to 
indicate  that  AUXAND  has  been  traversed,  and  a  pointer  is  set  to  the  top  entry  of  the 
and-stack.  "Notfound"  is  returned  from  the  semcheck  function  when  the  variable  d  is 
reached,  but,  since  the  AND  condition  has  been  set,  a  pointer  to  d  is  put  in  the  and-stack. 
Note  that  d  is  later  defined  in  a  data  definition  (DATAUXDEF  node),  and  when  both  the  left 
and  right  subtrees  of  AUXAND  have  been  checked,  all  variables  in  the  and-stack  are 
checked  against  variables  in  the  variable-stack.  If  a  match  is  found,  d  is  defined  and 
removed  from  the  and-stack.  In  the  event  that  a  variable  is  not  found  when  the  AUXAND 
node's  complete  subtree  has  been  checked,  an  error  condition  (UNDEFINED  VARIABLE) 
would  be  set.  The  semantic  checker  would  recognize  this  condition  because  the  top  of  the 
and-stack  would  not  be  equal  to  the  mark  placed  at  the  top  of  the  stack  when  the  AUXAND 
node  was  entered.  Nested  AUXANDS  are  possible,  but  they  pose  no  problem  because  the 
top  of  the  and-stack  is  marked  when  the  auxand  node  is  traversed. 
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Variables  and  functions  are  represented  in  the  run-time  by  a  call  to  an  assembly 
language  subroutine,  and  each  subroutine  must  have  a  discrete  name.  Also,  there  are 
several  labels  found  throughout  the  program,  and  each  of  these  must  have  a  name.  These 
names  are  generated  by  the  "name"  function  found  in  the  sem_u.c  module.  Each  name 
begins  with  the  letter  "a",  followed  by  6  digits.  Examples  can  be  seen  in  Figure  3.4. 
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1  \ 

x                    y 

Funauxdef 

Funid 

™    Formal 

f        \ 

x                       Comma 

/ 

y 
f  (x,y)  ==  x  *  y 

Figure  3.  9 
Tree  for  Function  f 

Function  definitions  presented  a  problem  that  was  solved  with  a  deviation  from  pure 
top-down  semantic  checking.  When  a  function  definition  (FUNAUXDEF  in  Figure  3.9)  is 
encountered  by  semantic  checker,  the  following  procedure  would  be  followed  (see  Figure 
3.10  for  the  function  definition  entry): 

funid   node: 

check  for  definition-stack  entry  for  "f ' 
if  not  found 

return  (ERROR) 
get  a  pointer  to  the  first  formal  of  f 
get  a  pointer  to  the  first  formal  of  definitions-stack  entry 

while  both  pointers  <>  Nil  do 
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put  variable  in  varstack;  use  type  pointed  to  by  the  formal  list 
advance  both  pointers 
end  while  loop 

if  not  (both  pointers  ==  nil) 

return  (FORMALS  MISMATCH) 
else 

put  "f '  in  the  variable-stack 

return  (Type  of  f  =  INTEGER) 
end  else 
end. 

fnnaiixrief  node: 

left  type  =  semcheck  (Left  Child) 
right  type  =  semcheck  (Right  Child) 

if  (left  type  <>  right  type) 

call  a  procedure  which  will  either 

convert  the  right  type  to  the  left  type  or  set  an  error  flag. 

endif 
end. 

When  a  function  is  called  with  arguments,    a  similar  process  takes  place  (refer  to 

Figure  3.11): 

actualist  :  Input  is  a  pointer  to  the  actualist  node 

Output  is  error  condition 

Check  definitions-stack  for  "f ' 
if  "f '  not  found 

set  error  (FUNCTION  DEFINITION  NOT  FOUND) 

set  elistptr  to  first  element  of  element  list 

elist  (elistptr) 

check  var  stack  for  "f ' 
if  found, 

generate  code  to  call  "f ' 
if  not  found 

ifand_flag  =  TRUE 

put  "f '  in  the  and  stack 
else 

set  error  (FUNCTION  NOT  DEFINED) 
end. 

elist:     Input  is  a  pointer  to  the  element  list  node 

if  pointer->rptr  <>  nil 

elist  (pointer->rptr) 

check  type  of  element  against  corresponding  formal  type 
if  types  don't  match 

set  error  (IMPROPER  ARGUMENT  TYPE) 
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else 


generate  code  to  put  pointers  to  argument  values  on  the  run-time  stack 


end. 


f 

Integer 

h 

$Z 

1 

\  Formal 
/Types 

$z 

V 

Figure  3.10 
Definitions-Table  Entry  For  Function  f 

Type  conversions  are  implemented  in  the  semantic  checker,  albeit  the  code  generator 
does  not  yet  support  this  feature.  The  function  hnumconvert  (half  number-convert, 
found  in  the  module  semO)  will  check  to  see  if  a  conversion  of  the  right  subtree  of  a  node 
to  the  left  subtree  type  should  be  accomplished.  This  is  useful  for  function  definitions, 
where  the  body  of  the  function  may  be  converted  to  the  type  the  function  returns,  but  the 
converse  is  not  acceptable.  In  addition,  the  function  numconvert  (found  in  the  semO 
module)  will  convert  either  the  left  tree  type  or  the  right  tree  type  of  a  node.  This  is  useful 
for  certain  arithmetic  operations.  The  semantic  checker  considers  integer-to-real  and 
natural-to-real  conversions  to  be  legal.  Natural  to  integer  conversions  are  not  implicitly 
done,  since  both  of  these  types  are  represented  in  exactly  the  same  way.  On  the  other 
hand,  an  attempt  to  return  an  integer  value  for  a  function  which  has  a  declared  type  of 
natural  will  result  in  an  error. 
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Figure  3.11 
Tree  for  Function  Call 

Variables  of  simple  type  (i.e,  natural,  integer,  or  real)  need  not  be  declared  before  use, 
although  such  a  declaration  may  be  made.  If  a  variable  is  undeclared  when  defined  by  a 
data  definition,  the  semantic  checker  will  attempt  to  classify  it.  If  the  semantic  checker 
expects  to  find  a  boolean  value,  the  variable  is  easily  classified  as  a  boolean  and  an  entry  is 
put  into  the  variable  table.  If  a  numeric  variable  is  expected,  the  semantic  checker  will  try 
to  type  it  as  an  integer;  failing  this,  it  will  be  classified  as  a  real  number.  However,  the 
AND  construct  alters  this  somewhat.  If  a  variable  is  used  before  it  is  defined  by  a  data 
definition,  it  must  have  been  defined  using  the  LETDEF  construct. 

As  noted  in  the  section  on  run-time,  some  thought  was  given  to  generating  all 
functions  and  data  definitions  to  one  buffer  and  the  "main"  program  which  calls  these 
functions  to  another  buffer.  However,  this  would  be  an  inefficient  use  of  memory  space, 
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since  one  buffer  might  run  out  of  space  while  the  other  is  under-utilized.  Although  there  is 
a  proliferation  of  jump  calls  in  the  output  using  one  buffer,  an  optimizer  could  easily 
eliminate  all  but  one  call,  as  noted  above. 

D.    OPTIMIZATION 

There  is  no  optimization  module  implemented  in  the  PHI  compiler.  In  this  section  an 
attempt  will  be  made  to  identify  three  types  of  optimization  which  are  suitable  for 
implementation.  Also,  a  small  dissertation  on  what  optimizations  should  not  be  considered 
is  included. 

The  first  suitable  type  of  optimization  is  constant  folding.  The  purpose  of  constant 
folding  is  to  eliminate  multiple  consecutive  constants  in  arithmetic  expressions  [Ref  3:p. 
612],  and  the  function  numconvert  in  module  semO  makes  an  excellent  structure  in 
which  to  implement  this  optimization.  This  is  because  most  arithmetic  operations  call  this 
function.  It  would  be  straightforward  to  put  a  function  that  tests  the  left  and  right  children 
of  an  operand  node  to  see  if  they  are  constants,  then  perform  the  operation  in  the  compiler 
and  generate  code  for  a  constant  call.  However,  since  the  division  operators  do  not  call 
numconvert,  the  constant  folding  function  would  have  to  be  inserted  in  idiv  and  rdiv 
also. 

The  other  two  optimizations  are  post-code  generation  optimizations.  The  first  one 
considered  is  jump  optimization.  This  should  be  the  most  worthwhile  to  implement:  if  the 
number  of  functions  and  data  definitions  is  n,  n  >  0,  there  will  be  n  -  1  unnecessary 
unconditional  jump  statements  and  labels. 

These  jump  statements  can  be  eliminated  by  replacing  the  first  "jmp"  statement  with  a 
jump  to  the  last  label  in  the  code;  then,  because  "jmp"  is  not  used  for  anything  except  to 
circumnavigate  functions  and  data  definitions,  all  other  unconditional  jumps  and  their  labels 
can  be  eliminated. 
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The  last  type  of  optimization  is  a  form  of  peephole  optimization.  Occasionally,  there 
will  be  a  "call  ppush"  statement  followed  by  a  "call  ppop"  statement.  This  is  unnecessary, 
and  can  be  eliminated.  The  8086  assembly  code  equivalent  of  "push"  followed  by  "pop" 
should  not  occur  in  the  present  design. 

Dead  code  optimization  eliminates  code  inside  a  jump  when  that  code  contains  no 
labels.  It  is  not  necessary  to  implement  this  type  of  optimization  with  the  current  design, 
since  unconditional  jumps  are  only  used  to  bracket  functions  and  definitions.  However,  if 
one  accepts  the  premise  that  programmers  occasionally  make  mistakes,  it  might  be 
worthwhile  to  keep  track  of  which  functions  are  called  and  eliminate  code  for  those  which 
are  not.  A  message  to  the  programmer  concerning  this  circumstance  would  be  useful,  too. 
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IV.    RESULTS  &  CONCLUSIONS 

A.    RESULTS 

The  implementation  described  in  this  study  demonstrates  the  design  and 
implementation  of  a  compiler  for  the  functional  programming  language  PHI.  Since  this 
implementation  is  a  prototype,  it  does  not  possess  all  of  the  qualities  desirable  in  a  full 
implementation.  However,  the  necessary  hooks  are  present  and  the  design  is  mature 
enough  to  allow  expanding  the  prototype  to  a  full  implementation. 

The  PHI  compiler  front-end  implements  machine  independent  lexical  and  syntactic 
analyzers.  This  implementation  is  complete  and  faithfully  follows  the  syntax  of  PHI  — 
based  on  the  design  of  the  language  as  of  07  January  1987.  In  deciding  which  modules  to 
include  in  the  front-end  and  back-end,  the  authors  were  originally  guided  by  the  traditional 
methodology  of  placing  the  analysis  functions  in  the  front-end  and  generative  functions  in 
the  back-end  [Ref.  8:p.  20].  However,  as  the  design  of  the  PHI  compiler  progressed,  the 
authors  removed  semantic  analysis  from  the  front-end  and  combined  it  with  code 
generation.  This  produced  a  one-pass  semantic  analysis/code  generation  phase. 

The  PHI  compiler  back-end  implements  a  machine  dependent  one-pass  semantic 
analyzer  and  Intel  8086  code  generator.  The  semantic  analyzer  implements  the  basic 
constructs  of  PHI:  functions  and  data  definitions  may  be  defined,  and  the  integer,  natural 
number,  real  number,  and  boolean  types  are  fully  implemented.  Implementation  of  code 
generation  is  congruent  to  that  of  the  semantic  analyzer,  with  the  exception  that  the  real 
number  data  type  has  not  been  implemented. 
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B.    CONCLUSIONS 

It  is  possible,  using  traditional  technologies  to  design  and  implement  a  compiler  for  the 
functional  programming  language  PHI.  It  is  not  possible  to  utilize  either  pure  recursive 
descent  or  pure  deterministic  techniques  for  this  implementation.  The  syntax/semantics  of 
the  language  forced  a  degree  of  non-determinism,  and  one  instance  of  back-tracking  was 
required  in  the  PHI  compiler  front-end. 

The  overall  design  is  highly  modularized  facilitating  the  understanding  of  concept  and 
implementation.  The  authors  think  that  this  approach  will  greatly  reduce  maintenance  costs 
and  provide  greater  flexibility  in  making  changes  and  additions  to  the  PHI  programming 
environment.  It  should  be  possible,  for  example,  to  use  the  front-end  described  in  this 
thesis  to  drive  a  PHI  interpreter.  Being  able  to  abstract  out  this  front-end  and  use  it 
without  change  should  make  the  implementation  of  a  PHI  interpreter  relatively  simple. 
Modularizing  the  design  also  increases  portability  of  the  compiler  to  other  machines.  To 
demonstrate  portability,  the  authors  recompiled  the  front-end  and  executed  it  on  a  68000 
based  processor.  This  was  accomplished  with  no  modifications  to  the  source  program,  just 
replacement  of  C  run-time  header  files  for  the  new  target  machine. 

Removing  the  semantic  analyzer  from  the  front-end  permitted  coupling  semantic 
analysis  with  code  generation.  The  fixed-length  buffer  design  of  the  code  generator  is 
suitable  for  this  prototype  implementation  but  should  be  redesigned  utilizing  dynamic 
buffer  allocation  methods  in  follow  on  implementations.  The  authors  think  that  utilizing  a 
single  pass  through  the  parse  tree  is  practical  for  the  basic  constructs  of  PHI  and  believe 
this  methodology  is  suitable  for  future  designs  of  the  PHI  compiler. 
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V.    FURTHER  RESEARCH 

Further  research  may  be  broken  down  into  two  major  areas:  short  and  long  range 
projects.  The  former  may  be  further  broken  down  into  two  main  areas:  adding 
unimplemented  features  and  improving  the  PHI  programming  environment.  On  the  other 
hand,  all  long-range  projects  involve  only  the  programming  environment.  All  of  these 
areas  are  discussed  below. 

In  the  prototype  of  the  PHI  compiler,  both  Real  and  Compound  variable  types  remain 
unimplemented.  Compound  variable  types  consist  of  sequences,  the  Trivial  type,  user 
defined  types,  and  tuples.  Although  all  of  these  are  recognized  by  the  parser,  the  semantic 
checker  will  not  recognize  complex  types  and  no  code  will  be  generated.  The  Real  type  is 
recognized  by  the  semantic  checker,  which  can  discern  if  conversion  from  an  integer  or 
natural  type  should  be  accomplished;  however,  no  code  is  generated  to  implement  this  type 
in  the  run-time  structures.  Note  also  that  operators  which  operate  solely  on  complex  types 
and  reals  (e.g.,  the  real  divide  and  concatenate  operators)  are  not  implemented. 

One  other  operator  not  implemented  is  the  "l->"  operator.  In  addition,  argument 
bindings,  functionals,  and  FILEs  are  not  recognized  by  either  the  semantic  checker  or  the 
code  generator. 

Short-range  improvements  to  the  PHI  environment  may  come  either  after  a  full 
implementation  is  accomplished  or  may  be  developed  concurrently  with  the  full 
implementation.  Admittedly,  the  current  environment  is  analogous  to  instrumentation  on  a 
helicopter:  there  is  just  enough  to  know  that  the  system  is  running!  The  environment  could 
be  improved  by  implementing  the  interactive  mode  of  PHI,  as  opposed  to  the  current  batch 
mode.  A  sample  interactive  session  of  PHI  may  be  found  in  [Ref.  l:pp  1-17].  Also,  an 
interpreter  would  be  a  good  starting  point  toward  developing  a  practical,  working 
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environment  for  PHI.  As  noted  above,  the  front  end  of  the  prototype  compiler  may  be 
adapted  for  this  purpose;  alternatively,  due  to  the  structual  similarities  between  PHI  and 
LISP,  an  ambitious  researcher  may  wish  to  write  an  interpreter  in  LISP. 

One  final  short-range  improvement  which  is  not  covered  by  either  category  would  be 
to  allow  more  than  64K  of  run-time  memory.  It  would  be  worthwhile  to  take  advantage 
of  the  large  amount  of  memory  most  modern  microcomputers  have,  especially  since 
sequences  and  recursion,  upon  which  PHI  is  based,  gobbles  up  memory  with  abandon. 

When  the  PHI  compiler  becomes  a  serious  user's  tool,  some  long-range  research  will 
become  viable.  Sophisticated  input  and  output  would  be  a  vital  consideration,  and  the 
minimal  I/O  methods  now  in  use  would  need  substantial  improvement.  The  most 
ambitious  researchers  in  this  direction  should  consider  a  bit-mapped  display  with  the 
possibility  of  a  syntax-directed  editor.  Also,  based  on  the  authors'  limited  experience  in 
PHI  programming,  a  debugger  would  be  a  necessary  tool  for  the  serious  programmer. 
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APPENDIX  A 
THE  FUNCTIONAL  LANGUAGE  PHI  —  O 

(CONCRETE  SYNTAX  OF  O  —  10/16/86  ) 


Grammatical  Notation: 


Both  '{Ci,C2,...,Cn}'  and 


Similarly, '[Ci  I  ...  I  Cn]'  and 


mean  exactly  one  of  Ci,  C2,...,  Cn. 


,/-.*. 


mean  at  most  one  of  C  l , . . . ,  Cn.  The  notation  'C 


means  zero  or  more  Cs;  'C+'  means  one  or  more  Cs;  'CD  ...'  means  a  list  of  one  or  more 
Cs  separated  by  Ds.  Terminal  symbols  are  quoted  when  they  could  be  confused  with 
metasymbols. 


Grammar: 

BLOCKBODY 
DEF 

QUALEXP 

AUXDEFS 
AUXDEF 

FORMALS 


f   QUALEXP 


LET  DEFS    ;  BLOCKBODY    J 

[ID]  FORMALS    =   QUALEXP 

ID   :    TYPEEXP 

TYPE  ID  [FORMALS]    =   TYPEEXP 

EXPRESSION  1 

QUALEXP  WHERE  AUXDEFS   J 


{ 


AUXDEF  AND... 

[ID]  FORMALS   ■  EXPRESSION 

I  ID  1 

I   (  FORMALS,  ...  )    J 


EXPRESSION 


[EXPRESSION  V]  CONJUNCTION 


CONJUNCTION 


[CONJUNCTION  A]  NEGATION 
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[  -  ]  RELATION 

[SIMPLEXP  RELATOR]  SIMPLEXP 

[=l*l>l<l<l>lele] 

[SIMPLEXEP  ADDOP]  TERM 

{  +    I   -   I   :   I    A   ) 

[TERM  MULOP]  FACTOR 

{  X    I   /   I   +  } 

II  primary 


APPLICATION 

PRIMARY    nT,TT„    mn„ 
APPUCATION 

[APPUCATION]  ACTUAL 

ID 

DENOTATION 
CONDITIONAL 
COMPOUND 
ARGBINDING 
BLOCK 
^  FILE    '  CHAR  +  '  J 


'CHAR      ' 
DIGIT+  [.  DIGIT+  ] 
FORMALS  |->  ACTUAL 

IF  ARM  ELSIF  ...  [ELSE  EXPRESSION]  ENDIF 
EXPRESSION  THEN  EXPRESSION 

f(  ELEMENTS)  ] 
\  '{'ELEMENTS  '}'  \ 
{  <  ELEMENTS  >     J 

[QUALEXP,  ...] 

f      OP  | 

'['<      OP  QUALEXP  >      ']' 
{     QUALEXP  OP  J 

(  ,  I  RELATOR  I  ADDOP  I  MULOP  I  !  } 
BEGIN  BLOCKBODY  END 
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DEFS 
TYPEEXP 
TYPEDOM 
TYPETERM 

TYPEFAC 

TYPEPRIMARY 
PRIMTYPE 


DEF  AND  ... 

TYPEDOM  [  ->  TYPEEXP 
TYPETERM  [  +  TYPEDOM  ] 
TYPEFAC  [  X  TYPETERM  ] 
f  TYPEPRIMARY 


TYPEPRIMARY 
ID  <<  TYPEEXP, 

ID  1 

PRIMTYPE        > 
(TYPEEXP )  J 


>> 


RIZIN 


I   1   I  TYPE 


For  batch  use,  a  program  is  considered  a  BLOCKBODY;  for  interactive  use  it  is  considered  a 
SESSION: 


SESSION 
COMMAND 


COMMAND+ 


f   DEF  1 

I  QUALEXP  J    ' 
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APPENDIX  B 
THE  FUNCTIONAL  LANGUAGE  PHI  —  O 

(CONCRETE  SYNTAX  OF  O  —  03/03/87  ) 


Grammatical  Notation: 


Both  '{Ci,C2,...,Cn}'  and 


Ci 

I  Cn  J 
Ci 


mean  exactly  one  of  Ci,  C2,..,  Cn. 


Similarly,  '[Cl  I ...  I  Cn]'  and 


LCn  J 


i/-.*! 


mt2J\  at  most  one  of  C  i,...,  Cn.  The  notation 'C  ' 


means  zero  or  more  Cs;  'C+'  means  one  or  more  Cs;  'CD  . . .'  means  a  list  of  one  or  more 
Cs  separated  by  Ds.  Terminal  symbols  are  quoted  when  they  could  be  confused  with 
metasymbols. 


Grammar: 


BLOCKBODY 


f   QUALEXP  1 

I   LET  DEFS    ;   BLOCKBODY    J 


DEF 


[REC] 


[ID,  ...  :  TYPEEXP  (BE  I  IS  }]  [ID]  FORMALS    =    QUALEXP 
TYPE  ID  [FORMALS]    ■   TYPEEXP 


QUALEXP 

AUXDEFS 
AUXDEF 

FORMALS 


f    EXPRESSION 

I  QUALEXP  WHERE  AUXDEFS 

AUXDEF  AND... 

[ID]  FORMALS   ■  EXPRESSION 


(ID 

I   (  FOR 


MALS,  ...  ) 


EXPRESSION 


[EXPRESSION  V]  CONJUNCTION 


CONJUNCTION 


[CONJUNCTION  A]  NEGATION 
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NEGATION 
RELATION 

RELATOR 

SIMPLEXP 

ADDOP 

TERM 

MULOP 

FACTOR 

PRIMARY 
APPLICATION 


ACTUAL 


DENOTATION 

CONDITIONAL 
ARM 

COMPOUND 

ELEMENTS 

ARGBINDING 

OP 


[  ""  ]  RELATION 

[SIMPLEXP  RELATOR]  SIMPLEXP 

(=|*l>l<l<l> 
[SIMPLEXEP  ADDOP]  TERM 

{  +  I  -  I  :  I  A  I  +  I  T) 

[TERM  MULOP]  FACTOR 

(X  I  / I  +  I  •  I  ;  I  X} 


e   I 


[:] 


PRIMARY 


J  APPLICATION 

I  PRIMARY 

I  APPUCATION 


[APPUCATION]  ACTUAL 

ID  [«  TYPEEXP,  ...»  ] 

DENOTATION 

CONDITIONAL 

COMPOUND 

ARGBINDING 

BLOCK 

{  FILE  I  STREAM  }'  CHAR  +  '  J 


'CHAR    * 

DIGIT+  [.  DIGIT+  ] 

NIL 


1 


^FORMALS  |->  ACTUAL   J 

IF  ARM  ELSIF  ...  [ELSE  EXPRESSION]  ENDIF 

EXPRESSION  THEN  EXPRESSION 

'['  ELEMENTS  ']' 
(ELEMENTS  ) 
'{'ELEMENTS  '}' 
<  ELEMENTS  > 

[EXPRESSION,  ...] 

rop  | 

'['  <   OP  ACTUAL  >  ']' 
I  ACTUAL  OP  J 

{  ,  I  RELATOR  I  ADDOP  I  MULOP  I  SUB  } 
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BLOCK 
DEFS 

TYPEEXP 

TYPEDOM 

TYPETERM 

TYPEFAC 

TYPEPRIMARY 
PRIMTYPE 


BEGIN  BLOCKBODY  END 
DEF  AND  ... 

TYPEDOM   [  ->  TYPEEXP  ] 

TYPETERM  [  +  TYPEDOM  ] 

TYPEFAC  [  X  TYPETERM  ] 

f  TYPEPRIMARY* 

I  TYPEPRIMARY  [  ACTUAL  ] 

f  ID  [  «  TYPEEXP,  ...»  ]  ] 
<  PRIMTYPE  > 

I (TYPEEXP)  J 

f  R   I  Z  I  N   I  B   I  1   I  TYPE 


For  batch  use,  a  program  is  considered  a  BLOCKBODY;  for  interactive  use  it  is  considered  a 
SESSION: 


SESSION 


COMMAND 


=      COMMAND+ 

f   LET  DEF    1 

"       I   QUALEXP   J    ' 
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APPENDIX  C 
ASCII  REPRESENTATION  OF 


-O 


Reference 

ASCII 

= 

== 

< 

LESS 

< 

<= 

> 

>= 

* 

<> 

G 

IN 

€ 

NOTIN 

V 

V 

A 

A 

X 

* 

/ 

/ 

-s- 

% 

— » 

-> 

A 

A 

k 

|-> 

Ai 

A!i 

T* 

T@ 

R 

$R 

Z 

$Z 

N 

$N 

B 

$B 

1 

$1 
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APPENDIX  D 
THE  FUNCTIONAL  LANGUAGE— O 

(  RIGHT-RECURSIVE  GRAMMAR ) 


Note:  (...) 
(-)+ 

(...)n 
(xly) 

BLOCK 
BLOCKBODY 

DEFS 
DEF 

QUALEXP 
AUXDEFS 
AUXDEF 
FORMALS 


means  zero  or  more  occurrences 

means  one  or  more  occurrences 

means  from  zero  to  n  occurrences 
means  either  x  or  y,  but  not  both 

::=  BEGIN  BLOCKBODY  END 

::=  LET  DEFS;  BLOCKBODY 
QUALEXP 

::=  DEF  (AND  DEFS)* 

::=  (ID)1  FORMALS   a  QUALEXP 

ID  :  TYPEEXP 

TYPE  ID  (FORMALS)1  a  TYPEEXP 
::=  EXPRESSION  (WHERE  AUXDEFS)* 

::=  AUXDEF  (AND  AUXDEF)* 

::=  (ID)1  FORMALS  a  EXPRESSION 

::=  (  FORMALS  (NORMALS)*  ) 
ID 


EXPRESSION  ::=  CONJUNCTION   (  V  CONJUNCTION) 


CONJUNCTION       ::=  NEGATION(  A  NEGATION) 


NEGATION  ::=  (-»)    RELATION 

RELATION  ::=  SIMPLEXEP  (RELATOR  SIMPLEXP)1 
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RELATOR 

;;=  = 

* 

LESS 

GREATER 

< 

> 

e 

€ 

SIMPLEXP 

::=  TERM(ADE 

ADDOP 

::=  + 

TERM 
MULOP 


:=  FACTOR  (MULOP  FACTOR) 


—  * 


FACTOR 

PRIMARY 

APPLICATION 
ACTUAL 


DENOTATION 


ID 

CONDITIONAL 
ARM 


+  PRIMARY 
-  PRIMARY 
PRIMARY 


APPLICATION  (!  APPLICATION) 
(ACTUAL)+ 


ID 

DENOTATION 

CONDITIONAL 

COMPOUND 

ARGBINDING 

BLOCK 

FILE  '(CHAR)+ 


:=  '(CHAR)    ' 

(DiGrr)+ 

(DiGrr)+ .  (DIGIT)+ 
FORMALS  |-»  ACTUAL 

:=  ALF  (ALFNUM)* 


Note:  CHAR  can  =  ASCII  32  ...  ASCII  126 

Note:  CHAR  can  =  ASCII  32  ...  ASCII  126 
Note:  DIGIT  can  =  0  ...  9 


Note:  ALF  can  =  a...z,  A...Z 
ALFNUM  can  =  a...z,  A...Z,  0...9,  _ 


IF  ARM  (ELSIF  ARM)    (ELSE  EXPRESSION)1  ENDIF 

EXPRESSION  THEN  EXPRESSION 
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COMPOUND 

::=  (  (ELEMENTS)    ) 
{  (ELEMENTS)1  } 
<  (ELEMENTS)1  > 

ELEMENTS 

::=  QUALEXP(,QUALEXP)* 

ARGBINDING 

::=  [  op  ] 

[  OP  QUALEXP  ] 
[  QUALEXP  OP  ] 

OP 

RELATOR 
ADDOP 

MULOP 

t 

• 

TYPEEXP 

::=  TYPEDOM   (  -»  TYPEDOM)* 

TYPEDOM 

::=  TYPETERM  (+  TYPETERM)* 

TYPETERM 

::=  TYPEFAC  (  *  TYPEFAC)* 

TYPEFAC 

::=  TYPEPRIMARY® 
TYPEPRIMARY 

ID  «TYPEEXP  (,TYPEEXP)*  » 

TYPEPRIMARY 

::=  (TYPEEXP) 
ID 
PRIMTYPE 

PRIMTYPE 

::=K 
7L 
N 

IB 
1 

TYPE 

SESSION 
COMMAND 


FOR  INTERACTIVE  IMPLEMENTATION  OF  O 

::=  (COMMAND)"*" 

::=  (DEF  I  QUALEXP)  ; 
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APPENDIX  E 
ROCK  COMPILER  HEADER  FILES 

/••••••A**************************************************************** 

*  THIS  FILE  CONTAINS  HEADER  FILES  REQUIRED  BY  THE  ROCK  COMPILER      * 
***********************************************************************/ 

/*********************************************************************** 

*  PUBLIC  DOMAIN  SOFTWARE  * 


*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 
*********** 

*  This  file 

*  error  rec 
*********** 

*  Modified 
* 
*********** 

#ifndef    EOF 


definitions 
h 
COLE  /  Capt  J.E.  CONNELL 


-  Update  keywords    JC 


scanner 
scanner . 
Ma  j  E.J. 
10/10/86 
12/11/86 
01/10/87 
************* 

contains  def 
overy  routine 
************* 

:   01/10/87 

of  the  1 
************************************************************ 


************************************************ 


initions  used  by  the  scanner, parser, 
s 


r****************** 


and       * 

* 

***************************** 


Corrections  to  comply  with  latest  definitions  * 
anguage  and  update  keywords.  JC  * 

/ 


♦define  EOF_  -2 

♦define  FALSE  0 

tdefine  TRUE  1 

#define  BYTENUM  2 
♦define  MAX_KEYWORDS   17 

♦define  NAMESIZE  18 

♦define  MAXLINE  80 

♦define  TABLESIZE  107 


/*  system  dependent  -  sizeof(int)  */ 
/*  really  18,  ranges  from  0-17  */ 
/*  length  of  str,  16  chars  +  ' \0 '    */ 


/*  hash  const/size  of  name  array 


'/ 


/*   General  Token   Types  */ 
/*  Listing  of  symbols  can  be  found  at  end  of  list  */ 


♦define 

EOLN_ 

3 

♦define 

LEQ_ 

4 

♦define 

NEQ_ 

5 

♦def ine 

ST_SEQUENCE_ 

6 

♦define 

GEQ_ 

7 

fdef ine 

END_SEQUENCE_ 

8 

♦define 

EQ_ 

9 

♦define 

ADD_ 

10 

♦define 

SUB_ 

11 

♦define 

MULT_ 

12 

♦define 

IDIV_ 

13 

♦define 

RDIV 

14 

♦define 

SEMI_ 

15 

♦define 

SUBSCRIPT 

16 
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# define  COMMA_  17 

♦define  LTPAREN_  18 

♦define  RTPAREN_  19 

#define  EQUIV_  20 

#define  ORLOG_  21 

#define  ANDLOG_  22 

#define  NEGLOG_  23 

♦define  COLON_  24 

♦define  CAT_  25 

♦define  LTBRAKET_  26 

#define  RTBRAKET_  2  7 

#define  LTSQUIG_  28 

#define  RTSQUIG_  29 

♦define  EMPT_LIT_  30 

♦define  RTARROW_  31 

♦define  LINERTARROW_  32 

♦define  LITERAL_  33 

♦define  IDENTIFIER_  34 

♦define  CONSTANT_  35 

♦define  REAL_  36 

♦define  INTEGER_  37 

♦define  NATURAL_  38 

♦define  BOOLEAN_  39 

♦define  TRIVIAL_  40 

♦define  CHAR_  41 

♦define  STRING_  42 

♦define  STAR_  43 

♦define  POS_  44 

♦define  NEG_  45 

♦define  KW_  4  6                           /*  KEYWORD 

/*  eof,  error,  unknown  token,  <=,  <>,  <,  >=,  >,  =,  +  ,  -,  *,  %,  /, 
,,  (,  ),  ==,  \//  A,  ~,  :,  A,  [,  ],  {,  \,     ",    ->,     l->,  literal, 
identifier,  constant,  $R,  $Z,  $N,  $B,$1,  character,  string,  @, 

unary  plus,  unary  minus,  keyword 

/*  Keywords  */ 


♦define 

AND_ 

0 

♦define 

BEGIN_ 

1 

♦define 

ELSE_ 

2 

♦define 

ELSIF_ 

3 

♦define 

END_ 

4 

♦define 

ENDIF_ 

5 

♦define 

FILE_ 

6 

♦define 

GREATER 

7 

♦define 

IF_ 

8 

♦define 

IN 

9 

♦define 

LESS_ 

10 

♦define 

LET_ 

11 

♦define 

NOTIN_ 

12 

♦define 

READ_ 

13 

♦define 

THEN_ 

14 

♦define 

TYPE_ 

15 

♦define 

WHERE_ 

16 

♦define 

WRITE 

17 
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#define   CALLOC(y,x)    ((x*)  calloc (y, sizeof  (x) )  ) 

struct    NStruct     {  /*  structure  to  hold  names  from    */ 

/*  user  prog  */ 

char  name[NAMESIZE] ; 

struct  NStruct   *link; 

}; 
typedef  struct  NStruct    NameRec; 
extern    char    *cailoc(); 
extern    char    *ina±loc(|  ; 

#endif 
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'********************************************************************** 


Name 

File 

Authors 

Started 

Archived 

Modified 


PUBLIC  DOMAIN  SOFTWARE 

parser  definitions 

parser .h 

Maj  E.J.  COLE  /  Capt  J.E.  CONNELL 

10/20/86 

12/11/86 

01/12/87  -  update  NodeStruct  definition  JC 


••••••••••••••••A****************************************************** 

*  This  file  contains  definitions  used  by  the  parser  * 
••a******************************************************************** 

*  Modified    :   01/10/87  -  update  NodeStruct  to  hold  the  type  of  the   * 

*  node  * 
a*********************************************************************/ 


#ifndef 

LETDEF 

#def ine 

LETDEF 

71 

#def ine 

DEFAND 

72 

#def ine 

KINDEF 

73 

#def ine 

FUN  ID 

74 

#def ine 

FUNDEF 

75 

#def ine 

DATADEF 

76 

#def ine 

TDEFID 

77 

#def ine 

TDEFFUN 

78 

#define 

DATAAUXDEF 

79 

#def ine 

FUNAUXDEF 

80 

#def ine 

AUXAND 

81 

#def ine 

ACTUALLIST 

82 

#def ine 

SEQUENCE 

83 

#def ine 

FORMAL 

84 

#def ine 

ELLIST 

85 

#def ine 

EMPTYCOMPOUND 

88 

#def ine 

EMPTYSEQUENCE 

89 

#def ine 

ARGBINDOP 

90 

#def ine 

ARGLEADOP 

91 

#def ine 

ARGTRAILOP 

92 

#def ine 

TYPEPLUS 

93 

#def ine 

TYPETIMES 

94 

#def ine 

TYPEEXPLIST 

95 

#def ine 

LEFT 

1 

#def ine 

RIGHT 

2 

#def ine 

ERROR_ 

-1 

#def ine 

BUFSIZE 

512 

typedef    int 

NodeType; 

struct  NodeStruct  { 

NodeType 

name; 

long 

index; 

int 

type; 

int 

In; 

char 

label  [8]; 

long 

addr; 

/*  operator  node  in  tree  */ 

/*  int  defined  as  the  operator  */ 

/*  pointer  to  constant , literal, id  */ 

/*  the  type  of  the  node  */ 

/*  line  no  in  source  text  where  */ 

/*   token  can  be  found  */ 

/*  Label  used  by  functions  to  */ 

/*  refer   to  code  */ 

/*  Addr  of  the  var  or  function  */ 

/*  value  in  the  run  time's  virtual*/ 

/*  memory  */ 
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struct  NodeStruct    *lptr; 

struct  NodeStruct    *rptr; 

}; 

typedef  struct  NodeStruct  NodeRec,  *nodal; 


/*  left  ptr 
/*  right  ptr 


NodeRec    *CreateNode ( ) ; 
char      *NodeName ( ) ; 

extern  int    num_errors; 
extern  int    argbind; 


/*  global  var-list  number  errors  */ 

/*  during  scan  and  parse  */ 

/*  global  flag  -  used  to  make  PHI  */ 

/*  deterministic  */ 


extern  char  *calloc() 
extern  char  *malloc() 
extern  ErrorHandler ( ) 
extern  WriteErrors () ; 


/*  def  used  from  <stdlibs.h> 


/*******•****•******  External  Utility  Functions  *****************/ 


extern  NodeRec  *CreateNode ( ) ; 
extern  char     *NodeName(); 
extern  MakeNewRoot ( ) ; 
extern  IsFormalO; 
extern  IBall () ; 
extern  EatEm ( ) ; 
extern  long  ByPass(); 

#include  <scanner.h> 
♦include  <errors.h> 

#endif 
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********************************************************************** 


PUBLIC  DOMAIN  SOFTWARE 


error 
erors 
Maj  E 
01/20/87 
04/07/87 


file  definitions 
h 

COLE  /  Capt  J.E 


*  Name 

*  File 

*  Authors    :    Mai  E.J.  COLE  /  Capt  J.E. 

*  Started 

*  Archived 

*  Modified 
*********************************************************************** 

*  This  file  contains  definitions  used  by  the  error  recovery  routines.  * 
*********************************************************************** 

*  Modified  * 


********************************************************************** 


/ 


♦ifndef 


MAXERRORS 


#define  MAXERRORS   10 

/***************•********  PARSER  ERRORS  *******************************/ 


#def ine 

ERRO 

0 

#def ine 

ERR1 

1 

#def ine 

ERR2 

2 

♦define 

ERR3 

3 

#def ine 

ERR4 

4 

#def ine 

ERR5 

5 

#def ine 

ERR6 

6 

#def ine 

ERR7 

7 

#def ine 

ERR8 

8 

♦define 

ERR9 

9 

#def ine 

ERR_a 

10 

#define 

ERR_b 

11 

#def ine 

ERR_c 

12 

♦define 

ERR_d 

13 

#def ine 

ERR_e 

14 

♦define 

ERR_f 

15 

♦define 

ERR_g 

16 

♦define 

ERR_h 

17 

♦define 

ERR_i 

18 

♦define 

ERR_j 

19 

♦define 

ERR_k 

20 

♦define 

ERR_1 

21 

♦define 

ERR_m 

22 

♦define 

ERR_n 

23 

♦define 

ERR_o 

24 

♦define 

ERR_p 

25 

♦define 

ERR  q 

26 

♦define 

ERR  r 

27 

/*  '  I  '  or  ' |-'  w/o  '>■  */ 

/*  RESERVED  FOR  FUTURE  USE  */ 

/*  '\'  w/o  '/'  —  bad  logical  OR  */ 

/*  '$'  w/o  proper  following  char  */ 

/*  invalid  numeric  constant  */ 

/*  literal  w/o  ending  */ 

/*  unidentified  char  in  input  file*/ 

/*  out  of  memory  */ 

/*  error  in  statement  following  */ 

/*  'xx'  */ 

/*  error  in  type  definition  */ 

/*  following  ' xx '  */ 

/*  unable  to  complete  eval  of  */ 

/*  the  blockbody  */ 

/*  missing  or  misplaced  ;  after  */ 

/*  definition  */ 

/*  invalid  QualExp  */ 

/*  invalid  TypeExp  */ 

/*  bad  or  missing  formals  *V 

/*  missing  or  misplaced  */ 

/*  missing  ID  after  'TYPE'  */ 

/*  bad  definition  after  AND  */ 

/*  missing  or  bad  AuxDef  after  */ 

/*  WHERE  */ 

/*  missing  or  misplaced  ' ) '  */ 

/*  error  in  processing  */ 

/*  successive  Actuals  */ 

/*  missing  literal  after  keyword  */ 

/*  FILE"  */ 

/*  missing  or  invalid  exp  after  */ 

/*  keyword  ==>  */ 

/*  IF  statement  w/o  ENDIF  */ 

/*  error  in  formals  preceding  I ->  */ 

/*  missing  or  invalid  QualExp  */ 

/*  following  comma  op  */ 

/*  error  in  ArgBinding  -  check  */ 

/*  QualExp   or  ]  */ 

/*  off  in  OZONE-unimplemented  */ 

/*  feature  */ 
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/* 
/* 

/* 
/* 
/* 
/* 
/* 
/* 

/*  NOTE:   s  through  z  reserved  for  future  use  */ 
/A*********************  SEMANTIC  ERRORS  ******************************/ 


#def ine 

ERR_ 

s 

28 

#def ine 

ERR_ 

_t 

29 

#def ine 

ERR_ 

u 

30 

#def ine 

ERR 

V 

31 

#def ine 

ERR_ 

w 

32 

#def ine 

ERR_ 

X 

32, 

#def ine 

ERR_ 

y 

34 

#def ine 

ERR 

z 

35 

♦define 

ERR_ 

aa 

35 

#def ine 

ERR_ 

~-hb 

35 

♦define 

ERR_ 

cc 

35 

#def ine 

ERR_ 

_dd 

35 

#def ine 

ERR_ 

ee 

35 

♦define 

ERR_ 

"ff 

35 

♦define 

ERR_ 

.99 

35 

♦define 

ERR_ 

_hh 

35 

♦define 

ERR_ 

ii 

35 

♦define 

ERR_ 

_jj 

35 

♦define 

ERR_ 

_kk 

35 

♦define 

ERR_ 

]ll 

35 

♦define 

ERR_ 

mm 

35 

♦endif 

/*  Numeric  value  expected  */ 

/*  Natural  expected  */ 

/*  Integer  or  natural  expected  */ 

/*  Error  in  Tuple  Definition  */ 

/*  Undefined  var  in  "and"  scope  */ 

/*  Function  w/o  function  def  */ 

/*  Formals  mismatch  */ 

/*  Undefined  function  */ 

/*  Real  Number  expected  */ 

/*  Invalid  Constant  */ 

/*  Boolean  value  Expected  */ 

/*  Boolean  Operator  Expected  */ 

/*  Out  of  run-time  memory  space  */ 
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/************* 

* 

* 

*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 
************** 

*  This  file  co 

*  checker  and 
************** 

*  Modified   : 


********************************************************* 

PUBLIC  DOMAIN  SOFTWARE  * 

* 

Semantic  Definitions  Header  File                      * 

Semcheck.h  * 

Maj  E.J.  COLE  /  Capt  J.E.  CONNELL                        * 

01/01/87 

04/10/87  * 

04/13/87   "FILENAME"  eliminated   EC  * 

********************************************************* 

ntains  the  header  file  and  definitions  for  the  semantic  * 
code  generator  of  the  PHI  compiler  * 

********************************************************* 

04/13/87   "FILENAME"  eliminated;  output  path  now        * 
depends  on  user's  input   EC  * 


********************************************************************** 


/****************************** 

♦include  <scanner.h> 

♦include  <parser.h> 

♦include  <errors.h> 

♦include  <stdio.h> 


Externals  ****************************/ 


/******************************* 

♦define  NOTFOUND  0 

♦define  UNTYPED  0 

♦define  BOOLEAN  1 

♦define  BOL_BYTES  2 

♦define  REAL  2 

♦define  REAL_BYTES  4 

♦define  INTEGER  3 

♦define  INT_BYTES  2 

♦define  NATURAL  4 

♦define  NAT  BYTES  2 


Globals  ******************************/ 
/*  Definition  for  findvar  */ 
/*  Type  Definitions  and  sizes     */ 


♦define  ERROR  0 
♦define  MAXADDR  64000 


/*  Max  ♦  of  bytes  in  var  space 


♦define  MAXTYPES  300 

♦define  CODE_SIZE  20000 
♦define  START_ADDR  0 
♦define     TYPE_INIT   5 

♦define    CNTRL_Z     2  6 
♦define     ENDSTRING  0 

♦define  NUM_BASE  4  8 

♦define  STACKSIZE  10000 

♦define  SIZEBUFFER  30000 


/*  Max  ♦  of  types  in  one  scope  */ 

/*  Max  size  of  code  buffer  */ 

/*  Starting  address  for  varspace  */ 

/*  Pointer  to  the  last  initial  */ 

/*  typetable  entry  */ 

/*  Control  Z  ascii  */ 

/*  String  terminator  */ 

/*  Lowest  ascii  number  */ 

/*  Increase  in  stack  size  */ 

/*  Size  of  output  buffer  */ 


♦define  ADD  1 

♦define  SUB  2 

♦define  DIVIDE 

♦define  MULT  4 


/*  Sem  check  codes  for  arith  ops 


♦define  SEM  ERR   0 


/*  Flag  to  indicate  semantic 
/*  error  follows 


♦ifndef  NULL 

♦define  NULL  0 
♦endif 
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*  * 

*  Type  Definitions  * 

*  * 

typedef  int  optype,  /*  Arithmetic  operations  */ 

FLAG,  /*  Generic  flag  type  */ 

PHITYPE;  /*  Types  found  in  language  */ 

typedef  char  stg  [20];  /*  Assembly  language  code  names  */ 

typedef  struct  and  struct  *and_ptr;  /*  Pointer  to  and_tabie  entries  */ 

/ ************************** *  Tvpetable  Definitions  ********************/ 

typedef  struct  typenode  {  /*  Typetable  entries  */ 
char  name  [ 10 ] ; 
int  bytes; 

struct  typenode  *typeptr; 
}  tnode; 

/•a**********************  Fonnallist  Definitions  **********************/ 

typedef  struct  formnode  {  /*  Formal  stack  */ 

int  name,  type;  /*  formname,  formtype  */ 

struct  formnode  "link;  /*  Link  for  list  */ 

)  fnode; 

/•it**********************  Vartable  Definitions  **********************■/ 

typedef  struct  varnode  {  /*  Entry  for  variable  stack  */ 

int  type,  /*  varname,  vartype  */ 

form,  /*  Flag  set  if  var  is  a  formal  */ 

def;  /*  True  if  var  is  a  definition  */ 

nodal  nptr;  /*  ptr  to  defining  node  */ 

fnode  *fptr;  /*  ptr  to  formals  */ 

struct  varnode  *link;  /*  Link  for  list  */ 

}  *varptr; 

/it***********************   Deftable  Definitions    **********************/ 

typedef    struct    defnode    { 

int    type;  /*    varname,    vartype  */ 

nodal    nptr;  /*    ptr   to   defining    node  */ 

fnode    *fptr;  /*   ptr    to    formals  */ 

struct    defnode    *link;  /*    Link    for    list  */ 
}    *defptr; 

/A**************************    And  Definitions    **************************/ 

struct    and_struct  /*    Structure    for    and   lists  */ 

{nodal   ptr;  /*    Ptr    to   nodal    containing   var    name 
*/ 

int    buffptr;  /*    Ptr    to   buffer    where  « 

/*    name    is    called  */ 

struct    and_struct    *link;  /*    Link    for    linked    list  */ 
}; 
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/••••A***************************************************************** 
*  PUBLIC  DOMAIN  SOFTWARE  * 


User  Header  * 

user.h  * 

Maj  E.J.  COLE  /  Capt  J.E.  CONNELL                        * 

04/01/87  * 

04/10/87  * 


*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 
*********************************************************************** 

*  This  file  is  the  header  file  for  the  user  interface  module  * 

*  (user.c)  * 
a********************************************************************** 

*  Modified   :  * 
•A********************************************************************/ 

/••it***************************  Globals  ******************************/ 
#define  BUFFLENGTH  30  /*  Max  size  of  input  file  name  +   */ 

/*  directory  */ 

#define  NOTFOUND  0 

#define  BSIZE  1000  /*  Input  buffer  size  */ 

#aefine  BLOCKSIZE  50  /*  Input  block  size  */ 

tdefine  BACKSPACE  8  /*  ASCII  Equivilents  */ 

#define  EOLN  13 
#define  ESCAPE  27 

#define  GETPROGRAM  "Program  to  Compile  ->  "        /*  Messages  to  observer  */ 

#define  HEADER1  "ROCK  COMPILER" 

#define  HEADER2  "Press  Escape  Key  to  Exit  Compiler" 

#define  FILE1_ERR0R  "File  not  Found" 

#define  FILE2_ERR0R  "Press  ESCAPE  to  exit,  any  other  key  to  continue" 

fdefine  WAIT  "Compiling:  Please  Wait" 

tdefine  PAUSE  "PRESS  ANY  KEY  TO  CONTINUE" 

#define  ERRORFILE  "errors. phi"  /*  Textfile  of  errors  */ 
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APPENDIX  F 
ROCK  COMPILER  —  MAIN  MODULE 

********************************************************************** 


/ 

*  PUBLIC  DOMAIN  SOFTWARE 


Name 

File 

Authors 

Started 

Archived 

Modified 


Main  Rock  Module 

Rock_main . c 

Maj  E.J.  COLE  /  Capt  J.E.  CONNELL 

01/06/87 

04/10/87 

04/13/87   Output  files  put  to  vdisk    EC 


*********************************************************************** 
*  This  file  contains  the  following  modules  for  the  PHI  compiler:       * 


R  Initial 


Semcheck 


Main 


*  Algorithm  : 

*  This  contains  the  main  procedure  for  the  phi  compiler,  in  add- 

*  ition  to  the  initialization  procedure  &  the  main  semantic  checking 

*  procedure.   The  main  module  inits  the  program,  sets  up  the  screen 

*  by  calling  "user  ()",  &  decides  whether  an  error  routine  needs 

*  to  be  called.   It  also  closes  out  the  input  file. 

*  The  "semcheck  procedure  is  designed  to  be  called  by  any  function 

*  with  a  ptr  to  a  parse  tree  node  as  an  argument.   It  will  then 

*  determine  which  sub-module  is  necessary  to  check  the  node. 

*  "R_Initial"  presently  has  the  function  of  initializing  the  type 

*  table. 


*********************************************************************** 

*  Modified  :   04/13/87   Output  files  written  to  vdisk,  "d:"    EC       * 
•••••••••a************************************************************/ 


/ 


**************************** 


Externals 


#inciude  <semcheck.h> 

extern  void  c_startup 
c_ending  ( )  , 
user  ( )  , 
user_err  ( )  , 
p_close  ( ) , 
set_page  ( ) , 
mov_cursor  ( ) ; 

extern  FLAG  err_found; 
extern  nodal  parser  () 


****************************** 


/*  Initializer  for  code  buffer  */ 

/*  Close  out  for  code  generator  */ 

/*  User  interface  */ 

/*  Error  writing  interface  */ 

/*  Close  source  file  */ 

/*  Change  video  display  page  */ 

/*  Move  cursor  to  specified  locat  */ 


***************************  Globals  ******************************/ 


/ 

unsigned  _stack  =  STACKSIZE; 
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/A*************************  r  Initial  **********************■*****•*/ 

void 
r  initial  ()  /*  Initialize  semantic  checking    */ 

{extern  tncde  types  []; 

strcpy  (types  [UNTYPED] .name,  "untyped") ;       /*  Set  up  type  table  */ 

types  [UNTYPED] .bytes  =  NULL; 
strcpy  (types  [BOOLEAN] .name,  "boolean"); 
types  [BOOLEAN] .bytes  =  BOL_BYTES; 
strcpy  (types  [REAL]. name,  "real"); 
types  [REAL]. bytes  =  REAL_3YTES; 
strcpy  (types  [ INTEGER] .name,  "integer"); 
types  [INTEGER] .bytes  =  INT_BYTES; 
strcpy  (types  [NATURAL] . name,  "natural"); 
types  [NATURAL] .bytes  =  NAT_BYTES; 
} 

/••A**********************  SemChecker  ***************************/ 

PHITYPE 
semcheck  (ptr)  /*  Breaks  Sem  Check  into  cases     */ 

nodal  ptr; 
{extern  PHITYPE  tkindef  (),  trtarrow  (), 

tfunid  (),  tid  (),  tconstant  (),  tactuallist  (),  tactuals  (); 
PHITYPE  type; 

switch  (ptr->name)  { 
case  (ADD_)  : 
case  (SUB_)  : 
case  (MULT_) 
case  (RDIV_) 
case  (IDIV_) 
case  (COLON_)  : 
case  (CAT_)  :  type  =  arithop  (ptr)  ; 

break; 
case  (POS_)  : 
case  (NEG_)  :  type  =  tprimary  (ptr) ; 

break; 
case  (ORLOG_)  :  type  =  tor  (ptr); 

break; 
case  (ANDLOG_)  :  type  =  tand  (ptr) ; 

break; 
case  (NEGLOG_)  :  type  =  tnegation  (ptr) ; 

break; 
case  (KINDEF)  :  tkindef  (ptr) ; 

break; 
case  (RTARROW_)  :  type  =  trtarrow  (ptr); 

break; 
case  (LETDEF)  :  tletdef  (ptr)  ; 

break; 
case  (KW_  +  WHER£_)  :  type  =  twhere  (ptr) ; 

break; 
case  (AUXAND)  :  tauxand  (ptr) ; 

break; 
case  (DATAAUXDEF)  :  tdatauxdef  (ptr) ; 

break; 
case  (FUNAUXDEF)  :  type  =  tfunauxdef  (ptr) ; 

break; 
case  (FUNID)  :  type  =  tfunid  (ptr); 

break; 
case  (ACTUALLIST)  :  type  =  tactuals  (ptr) ; 

break; 
case  (COMMA  )  : 
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case  (ELLIST)  :  telist  (ptr); 

break; 
case  (TYPETIMES)  :  type  =  ttypetimes  (ptr); 

break; 
case  (EQ_)    : 
case  (LEQ_) 
case  (NEQ_) 
case  (GEQJ 
case  (KW_  +  GREATER_)  : 
case  (KW_  +  LESS_)  : 
case  (KW_  +•  IN_)  : 
case  (KW_  +  NOTIN_)  :  type  =  tcomp  (ptr) ; 

break; 
case  (KW_  +  IF_)  :  type  =  tif  (ptr) ; 

break; 
case  (KW_  +  ELSE_)  :  type  =  telse  (ptr) ; 

break; 
case  (KW_  +  THEN_)  :  type  =  tthen  (ptr); 

break; 
case  (KW_  +  ELSIF_)  :  type  =  telseif  (ptr) ; 

break; 
case  (IDENTIFIER_)  :  type  =  tid  (ptr); 

break; 
case  (CONSTANT_)  :  type  =  tconstant  (ptr) ; 

break; 
case  (REAL_)  :  type  =  REAL; 

break ; 
case  (INTEGER_)  :  type  ==  INTEGER; 

break; 
case  (BOOLEAN_)  :  type 

break; 
case  (NATURAL_)  :  type  =  NATURAL; 
break; 


default  :  terror  (ERR_r,  ptr->ln) ; 

break; 
} 


/*  Unimplemented  feature  found,    */ 
/*  so  sandbag  programmer  */ 


return  (type) ; 


/****••*****•***********■*•*•****   Main 
main    ( ) 
{extern    char    prefix    []; 

extern    void   curson    (),    cursoff    (); 

char    name_holder     [30]; 

nodal  root; 


A*******************************/ 

/*  Prefix  of  the  souce  file  */ 

/*  Turn  cursor  on  and  off  */ 

/*  Holder  for  prefix  name  */ 

/*  Root  of  the  Parse  tree  */ 


c_startup  ( ) ; 
r  initial  ( ) ; 


/*  Initialize  and  open  files 


user  0 ; 
if  (root 


parser  () 


set_page  (2 ) ; 
cursoff  ( ) ; 
semcheck  (root); 


/*  User  interface 

/*  Parse  code;  continue  if  root 

/*  not  equal  to  nil 

/*  Freeze  current  video  display 

/*  Semantic  check  and  code  gen 


if  ( ! err_f ound) 
c  ending  ( ) ; 


/*  Clean  up  and  close  out  files 
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forkl  ( "d: rasm86 .exe",  "d: rasm86 .exe" ,       /*  Assemble  the  code  */ 

prefix,  NULL) ; 
forkl  ( "d: link86 .exe",  "d: link86 .exe" ,       /*  Link  object  files  together     */ 
•prefix,",",  "d:u",  NULL); 

strcpy  (name_h older ,  prefix) ; 

strcat  (name_holder,  ".1st");  /*  clean  up  the  loose  files       */ 

remove  (name_holder ) ; 

strcpy  (name_holder ,  prefix) ; 

strcat  (name_holder ,  ".sym"); 

remove  (name_holder) ; 

set_page  (0) ; 

curson  ( )  ; 

}        ) 

if  (err_found  I  I  !  root  )  {  /*  Print  error  files  if  req       */ 

set_page  ( 0) ; 

curson  ( ) ; 

user_err  ( ) ; 
} 
p_close  ();  /*  Close  source  file  */ 

execl  ("rock. exe",  "rock. exe",  NULL);  /*  Execute  rock  again;  exit  comes  */ 

/*  from  inside  main  Procedure      */ 
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APPENDIX  G 
ROCK  COMPILER  —  SCANNER 


/*********************************************************************** 

*  PUBLIC  DOMAIN  SOFTWARE                     * 

Scanner  * 

Scan2 . c  * 

Maj  E.J.  COLE  /  Capt  J.E.  CONNELL                          * 
10/10/86 

12/11/86  * 

04/23/87  tokens  no  longer  output  to  intermediate  file.  * 


v 


*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 
************************************************************************ 

*  This  file  contains  the  execution  modules  for  the  scanner:  * 

*  * 

*  GetTokenO,  IsKeyWordO 

*  * 

*  Algorithm  :   GetToken  is  called  from  FillBufferO  and  returns  an      * 

*  integer  code  to  uniquely  identify  the  token.  * 

*  IsKeyWordO  checks  each  identifier  to  insure  it's  not    * 

*  a  PHI  Keyword.  * 
************************************************************************ 

*  Modified    :   01/10/87  Corrections  to  comply  with  latest  definitions  * 

*  of  the  language.  JC  x 

*  :   01/10/87  GetTokenO  returns  CONSTANT_  vice  REAL_  or     * 

*  INTEGER_.  JC  * 

*  :       01/21/87    Error   Recovery   added   and   files    combined.    JC         * 

*  :       03/10/87    Corrections    to   partially   comply   with    latest         * 

*  definitions    of    the    language.    JC  * 

*  :       04/23/87    tokens    no    longer    output    to    intermediate    file      * 

*  GetToken   called  directly  by  the   Parser   now.  * 
•••••••••••••••••a*****************************************************/ 

♦include    <scanner.h> 
♦include    <stdio.h> 
♦include   <errors.h> 
♦include    <ctype.h> 

extern        FILE    *infile,    *errorfile;  /*   working    files  */ 

/**********************************************************************/ 

int 
GetToken (token) 
char    *token; 

/*    Calls    fgetc  (inf ile)     for   the    next    char    from  the    input    file    &    builds  * 

*  the   token   a   char   at   a   time.         Returns    an   internal    integer   value  * 

*  representing   the    type    of    token    found  */ 
{ 

/*    lookahead    is    a    flag,    line_num      */ 
static    int    lookahead   =   FALSE,    line    num   =    1;  /*    is    current    line    ♦    of    user    prog    */ 
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static  char  ch; 

int     i,  k; 

extern  ErrorHandler  ( ) ; 

while (TRUE) 
{   i  =  1; 

if  (! lookahead) 

ch  =  fgetc (inf ile) ; 
lookahead  =  FALSE; 

while  ( isspace (ch) ) 
{   if (ch  ==  '\n' ) 

{   +-  +  line_num; 
return (EOLN_) ; 

} 

ch  =  fgetc (inf ile) ; 


if  (ch  ==  EOF  )    return (EOF  ); 


switch (ch) 


case 
case 
case 
case 
case 
case 
case 
case 
case 
case 
case 
case 
case 
case 
case 
case 


return (ADD_) ; 
return (MULT_  ) ; 
return (IDIV_) ; 
return (SEMI_) ; 
return (SUBSCRIPT^) ; 
return (COMMA_) ; 
return (LTPAREN_) ; 
return (RTPAREN_) ; 
return (NEGLOG_) ; 
return (COLON_) ; 
return (CAT_) ; 
return  (STAR_) ; 
return  (LTBRAKET_); 
return  (RTBRAKET_) ; 
return (LTSQUIG_) ; 
return (RTSQUIGJ ; 


case 

if  ( (ch  =  fgetc (inf ile) )  ==  '>') 

return  (RTARROW_) ; 
else  if (ch  ==  '-' ) 
{   while((ch  =  fgetc (inf ile) ) 
!=  '\n'  &S  ch  !=  EOF) 

if  (ch  ==  '\n') 

{   ++line_num; 

return (EOLN_) ; 

)   else   return (EOF_) ; 
} 
else 

lookahead  =  TRUE; 
return (SUB_) ; 

case  '  <  '  : 

if((ch  =  fgetc(infile) )  ==  '=') 

return (LEQ_) ; 
else  if(ch  ==  ■>•) 

return (NEQ_) ; 
else  lookahead  =  TRUE; 


/*  ch  holds  last  character  from  */ 

/*  input  prog  */ 

/*  i  =  index  into  token  array;  */ 

/*  k  =  temp  holder  for  tokens  */ 


/*  initialize,  token  name  — 
/*  will  start  at  token[l] 


/*  process  carrage  returns 

/*  end  if  ' \n ' 

/*  end  while  white  space 

/*  reached  end  of  the  file 


/*  process  comment 


/*  do  nothing 


/*  end  else  if  comment 
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return (ST_SEQUENCE_) ; 

case  ' >  '  : 

i'f  (  (ch  =  fgetc(infile)  ) 

return (GEQ_) ; 
else  lookahead  =  TRUE; 
return (END  SEQUENCE  ) ; 


case  '=' : 

if((ch  =  fgetc (inf ile) )  == 

return (EQUIV_) ; 
else  lookahead  =  TRUE; 

return (EQ  )  ; 


.  =  .) 


case  '  /  '  : 

if((ch  =  fgetc  (inf ile) )  == 

return (ANDLOG_) ; 
else  lookahead  =  TRUE; 
return (RDIV  ) ; 


■W) 


case  ' \ \  '  : 

if((ch  =  fgetc (inf ile) )  ==  '/') 

return (ORLOG_) ; 
else 

lookahead  =  TRUE; 
ErrorHandler (line_num, ERR2,NULL) 
return (ORLOG  ) ; 


/*  figured  that's  what  he  wanted 


case  '  I  '  : 

if((ch  =  fgetc  (inf ile) )  ==  '-') 
if((ch  =  fgetc (infile) )  ==  ■>') 
return (LINERTARROW_) ; 
lookahead  =  TRUE; 
ErrorHandler ( line_num,  ERRO,  ch)  ; 
return (LINERTARROW  ); 


/*  ch  is  either  ' I '  or  '-'         */ 
/*  figured  that's  what  he  wanted   */ 


case  ' $ '  : 

ch  =  fgetc ( inf ile) ; 

if  ( (ch  ==  'R' )  ||  (ch  ==  'r ' ) ) 

return (REAL_) ; 
else  if  ( (ch  ==  'N' )  ! I  (ch  == 

return (NATURAL_) ; 
else  if  ( (ch  ==  'Z' )  II  (ch  == 

return (INTEGER_) ; 
else  if  ( (ch  ==  'B')  II  (ch  == 

return (BOOLEAN_) ; 
else  if  (ch  ==  ' 1 ' ) 

return (TRIVIALJ ; 
else  lookahead  =  TRUE; 
ErrorHandler (line_num, ERR3, NULL 
return (INTEGERJ  ; 


'n')  ) 
'z'  )  ) 
■b")  ) 


/*  default  return  type 
/*  end  switch 


if  (  isalpha (ch) ) 
{   do 

{   token [i++]  =  ch; 
ch  =  fgetc ( inf ile) ; 

}    while  (isalnum(ch) 

token[i]  =  '\0'; 

lookahead  =  TRUE; 


ch 


/*  starts  with  a  letter 


/*  end  do 

/*  end  the  string 

/*  now  check  to  see  if  it's  a 

/*  KEYWORD 


*/ 
-/ 

-/ 

*/ 
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if((  k  =  IsKeyWordftoken  +1))  >=  0) 
return (KW_  +  k) ; 

return (IDENTIFIER_) ; 
I 

if  (isdigit (ch) ) 
{   if (ch  ==  '0' ) 

{   while (  (ch=fgetc(inf ile)  )  ==  '0') 

if ( ! isdigit (ch) ) 

token[i++]  =  ' 0 ' ; 
} 

while (isdigit (ch) ) 
{   token [i++i  =  ch; 

ch  =  fgetc  (inf ile) ; 
} 

if  (ch  ==  ' . ' ) 
{   token [i++]  =  ch; 
ch  =  fgetc (inf ile) ; 
if  ( ! isdigit (ch) ) 
(   token[i]  =  '\0'; 

Error Handler (line_num, ERR 4, 

token+1) ; 
token [i  +  1]  =  token  [i]; 
token [i]  =  0; 
return (CONSTANT_) ; 
)  else 
do 
(   token  [i++]  =  ch; 

ch  =  fgetc  (  inf ile) ; 
}   while (isdigit (ch) ) ; 

'\0'; 


} 

token [i ] 
lookahead  =  TRUE; 
return (CONSTANT^) ; 
} 

if  (ch  ==  'V ' ) 
(   token [ i  +  + ]  =  ch; 

while  (  (  (ch= fgetc (inf ile) )  !=EOF)  SS 
(ch!='\n')  &&  (i<  MAXLINE) ) 
{   token [i++]  =  ch; 
if  (ch  ==  '\") 

if  (  (ch  =  fgetc  (inf  ile)  )  !=  >\") 
{   lookahead  =  TRUE; 
token [i]  =  '\0'; 
if  (strlen  (token)  >  3) 

return  (LITERAL_) ; 
return  (EMPT  LIT  ) ; 


} 


} 


token[i]='\0'; 

ErrorHandler ( line_num, ERR 5, token+1) ; 

return (LITERAL_) ; 

} 


/*  Return  Adjusted  Keyword  index   */ 
/*  to  calling  routine  */ 

/*  end  if  alfa  char  */ 


/*  do  nothing,  eat  zeros 


/*  end  if  leading  0 


/*  end  while  is  a  digit 


/*  fix  for  insertion  into 
/*  name  table 

/*  end  if  not  a  digit 


/*  end  do 

/*  end  if  ch  ==  ' . 

/*  end  the  string 


/*  end  if  isdigit 
/*  process  LITERALS 


/*  end  if  !=  ' 

/*  end  while 

/*  end  the  string 

/*  figured  that's  what  he  wanted 

/*  end  if  literal 


ErrorHandler (line  num, ERR6, &ch) ; 


/"  Default  -  char  not  recognized   */ 


continue; 


/*  let's  try  again 
/*  end  while  (true) 
/*  end  GetTokenO 
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/••a***********************         Scanner   Utilities         it*********************/ 

int 
IsKeyWord(token) 
char  *token; 

/*  Checks  to  see  if  the  input  token  is  a  keyword  in  the  language.  * 

*  If  it  is,  the  function  returns  the  numeric  value  of  the  keyword.  * 

*  If  it  isn't,  the  function  returns  -1 .   Performs  binary  search  of  * 

*  keyword  array  -  * 

*  MUST  KEEP  THIS  ARRAY  IN  ALPHABETICAL  ORDER! !  */ 

{ 

int      i; 

register  int    lo  =0,  hi  ,  mid; 

/*  list  of  PHI  keywords  -  KEEP  in  */ 
/*  alphabetical  order!!  */ 

char     s [MAXLINE] ; static    char    *keywords[]  = 

{  "AND",  "BEGIN",  "ELSE" , "ELSIF" , "END" , "ENDIF", "FILE", "GREATER", "IF", 
"IN", "LESS", "LET", "NOTIN", "READ", "THEN", "TYPE", "WHERE",  "WRITE"  } ; 

strcpy ( s, token) ; 

for (i  =  0;  s[i]  !=  '\0' ;i++) 

if('a'  <=  s[i]  SS  s[i]  <=  'z'l  /*  insure  letters  are  upper  case   */ 

s[i]  +=  'A'  -  'a'; 

hi  =  (sizeof (keywords) /sizeof  (char*) ) ; 

whiledo  <=  hi) 

{   mid  =  (lo  +  hi) 12; 

if((i  =  strcmp (s, keywords [mid] )) <0) 

hi  =  — mid; 
else  if(i>0) 

lo  =  ++mid; 
else 

return(mid);  /*  found  a  keyword  */ 

}  /*  end  while  */ 

return(-i);  /*  didn't  find  a  keyword  */ 

}  /*  end  IsKeyWord  */ 
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APPENDIX  H 
ROCK  COMPILER  —  PARSER 


/*********************************************************************** 

*  PUBLIC  DOMAIN  SOFTWARE 

parser  pt  I 
parserl . c 

Maj  E.J.  COLE  /  Capt  J.E.  CONNELL 
10/20/86 
12/11/86 

04/23/87  No  longer  set  up  to  work,  with  file  of  tokens.  * 
************************************************************ 

contains  the  following  modules  for  the  PHI  parser:  * 


*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 
************ 

*  This  file 


BlockBo 
AuxExp ( 

Algorithm 


dyC 
) 


LetDefs () 
AuxDef s ( ) 


Defs  () 
AuxAnd ( ) 


DefAndO 
Formals ( ) 


QualExp  () 
Expression ( ) 


The  main  module  calls  BlockBodyO  to  start  the  parse 
off.   BlockBody  in  turn  calls  LetDefs  ()  first  and  then 
QualExp ()  looking  for  a  valid  program.    The  remaining 
modules  in  Pt ' s  1-3  are  called  by  these  when  trying  to 
validate  a  pargram.   The  results  from  the  parse  are  now 
kept  in  an  abstract  syntax  tree  for  type  checking  and 
code  generation.   Various  utility  functions  are  used 
to  build  the  tree  and   simplify  parsing  the  grammer. 


************************************************************************ 


*  Modified 


12/26/86  Flattened  tree  output  changed  to  abstract 

syntax  tree  form.  JC 

01/10/87  Corrections  to  comply  with  latest  definitions 

of  the  language.  JC 

01/27/87  Error  Recovery  added  and  files  combined.  JC 

03/20/87  Token  buffer  implemented  for  parser.  JC 

03/29/87  Changed  manner  errors  are  handled  —  required 

for  integration  with  back-end. 

04/23/87  No  longer  set  up  to  work  with  file  of  tokens. 

GetToken  is  called  directly  thru  FillBuffO.     JC 


*********************************************************************** 


^include  <stdio.h> 
#include  <parser.h> 

int     rtbrket  =  FALSE,  argbind  =  FALSE; 

int     line  no  =  1; 


/*  global  flags  -  aid  in  making  */ 

/*  PHI  deterministic  */ 

/*  global  var,  current  line  no  */ 

/*  of  program  */ 

/*  tokenbuff  holds  tokens  provided*/ 

/*  by  GetToken 0  -  ptr  is  a  ptr  to*/ 

/*  next  token  in  tokenbuffer  -  */ 
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/*  must  use  "long"  because  buffer  */ 

/*  holds  addresses  */ 

/*  use  BUFSIZE  t  1  in  case  have  to"/ 

/*  place  address  of  'name  at  end   */ 

/*  of  buffer  */ 

long    tokenbuff [BUFSIZE+1] ,  *ptr  =  & tokenbuff ( BUFSIZE ] ; 

FILE    *poutfile,  *errorfile;  /*  working  files  */ 

/******•*•*************************************************************/ 

nodal 
Parser  () 
{ 

NodeRec    "root  =  NULL; 
extern    void  p_close(),  mov_cursor ( ) ;  /*  external  asm  functions         */ 

num_errors  =  0;  /*  init  number  jof  errors         */ 

errorfile  =  f open ("errors .phi", "w") ; 

fprintf (errorfile, "%40s\n\n", "ROCKY  ERRORS") ; 

f close (errorfile) ;  /*  rewrite  file  for  clean  start    */ 

fifdef    DEBUG 

poutfile  =  fopen ( "parser . out" , "w" ) ; 
#endif 

BlockBody (Sroot )  ;  /*  look  for  a  valid  program       */ 

if ( !ByPass (EOF_)  ) 

{   mov_cursor (20,  0)  ;  /*  set  cursor  on  screen  to        */ 

print f ( "WARNING  ...additional  text  found     /*  found  extra  junk,  tell  user     */ 
at  completion  of  your  program  - 
line  %d\n", line_no) ; 
}  /*  end  if  not  end  of  user's  prog   */ 

#ifdef    DEBUG 

if  (root  !=  NULL)  /*  write  parser's  output  */ 

/*  to  data  file  */ 

PostOrder ( root ) ;  /*  case  it's  needed  for  debugging  */ 

fprintf (poutfile, "\n") ;  /*  need  that  carrage  return       */ 

f close (pout  file)  ; 
#endif 

fclose(infile) ; 

p_close  ( )  ; 

if  (num_errors  >  0) 

return (NULL) ; 
else 

return (root) ; 
}  /*  end  main  */ 

/••A*******************************************************************/ 

void 
PostOrder ( root) 

NodeRec     *root; 

/*    Does  a  post  order  walk  of  the  tree  with  (root)  as  its  head.      */ 
/*     Just  prints  out  the  node  name  to  the  screen  now  */ 

{ 
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static  ir.t  1 


Oj 


if  (root  !=  NULL) 
{   PostOrder (root->lptr)  ; 
PostOrder (root  ->rptr) ; 

switch  (root->name) 
(   case  IDENTIFIER    : 
case  CONSTANT_      : 
case  LITERAL_       : 

{  fprintf (pout file,  "%d  ",root  ->name) ; 
fprintf (poutfiie, "%ld    ", root->index) 
break;  } 

default  : 

fprintf (poutfiie, "%d    ",root  ->name) ; 
} 
if  (  (  (  ++i  %  7)==0))   fprintf (poutfiie,  "\n")  ; 
} 


/*  used  in  pretty  printing  parser  */ 
/*  output  file  */ 


/*  end  ID, CONSTANT, LITERAL 


/*  end  switch 

/*  end  root  !=  NULL 
/*  end  PostOrder ( ) 


/••••••••••A***********************************************************/ 


BlockBody (root) 

NodeRec    **root; 


/*  root  is  a  ptr  to  tree/subtree   */ 
/*  currently  working  with         */ 


<BLOCKBODY> 


<QUALEXP>  I  <LETDEFS> 


flag; 


iff ((flag  =  LetDefs (root) )  ==  TRUE)) 
return (TRUE) ; 

else  if (flag  !=  ERROR_) 
flag  =  QualExp (root ) ; 


/*  looking  for  LETDEFS; BL0CK30DY   */ 
/*  look  for  plain  ol'  QUALIX?      */ 


return ( flag) ; 

} 
/••••••••A*************************************************************/ 


mt 
LetDefs  (root) 

NodeRec    **root; 


/*  root  is  a  ptr  to  tree/subtree   */ 
/*  currently  working  with         */ 


/*  <LETDEFS>     : 

{ 

tifdef    DEBUG 

printf("    ietdefs    entered\n");         scanf("%*c" 

#endif 


let    <DEFS>    ;    <BLOCKBODY> 


if (ByPass (KW_  +  LET_) ) 

i   "root  =  CreateNode (LETDEF) ; 

if  (Defs (4 ( ('root) ->lptr)  )  !=  TRUE) 
ErrorHandler (line_no, ERR_a, 
(long)SEMI_) ; 

if (!ByPass (SEMI_) ) 

ErrorHandler (line_no, ERR_b, 
(long) SEMI_) ; 
ByPass (SEMI_) ; 
if ( (BlockBody (& ( (*root) ->rptr) )  == 

return (TRUE) ; 
ErrorHandler (line  no, ERR  a, NULL); 


TRUE) ) 


/*  starts  off  with  LET 

/*  start  off  the  tree 

/*  look  for  the  definitions 

/*  report  it,  try  &  fix 


/*  report  it  &  try  to  continue 


/*  found  everything 
/*  report  it,  no  fix 
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return (ERROR  ) ; 


#ifdef  DEBUG 
printf!"  letdefs  exited\n")  ;    scanf("%*c") 

#endif 

return (FALSE) ; 


/*  started  LETDEFS  but  couldn't    »/ 
/*  finish  */ 

/*  end  ByPass  LET  */ 


/*  default  -  no  LET  at  beginning 
/*  end  LetDefs 


/A*********************************************************************/ 


int 
Def s (root) 
NodeRec 


'root; 


/*    root    is    a    ptr    to   tree/subtree      */ 
/*    currently   working   with  */ 


/*    <DEFS> 

/* 

/* 

{ 

NodeRec        "temp; 

int  flag; 

long  id   ptr; 


=     (<DATADEF> | <FUNDEF> | <KINDEF> | <TDEFID> | 
<TDEFFUN>)        <DEFAND> 
Where    "<DEFAND>    "    need  not   be   present 


/*    address    of    data    struct 
/*    holding    identifier    name 


extern 


long    *ptr; 


if(id_ptr  =  ByPass (IDENTIFIERJ  ) 
{    temp  =  CreateNode (IDENTIFIER^ 
temp  ->index  =  id_ptr; 


/*  set  up  itsside  of  subtree 


if  (ByPass (EQUIV_)  ) 

{   *root  =  CreateNode (DATADEF) ; 

(  *root) ->lptr  =  temp; 

if  (QualExpU  (  (*root)  ->rptr)  )  !=  TRUE) 

ErrorHandler ( line_no, ERR_c, 
(long) KW_+AND_) ; 
} 
else    if (ByPass (COLON_) ) 
{   *root  =  CreateNode (KINDEF) ; 
(•root)  ->lptr  =  temp; 
if ( (TypeExp(& ( (*root) ->rptr) ) !=  TRUE) ) 

ErrorHandler (line_no, ERR_d, 
(long) KW_+AND_) ; 
} 
else 

f   'root  =  CreateNode (FUNDED ; 

(•root)  ->lptr  =  CreateNode (FUNID) ; 
(*root)  ->lptr->lptr  =  temp; 
if  (  ( Formal s  (&  (Toot)  ->lptr->rptr ) 

!=TRUE) ) 
ErrorHandler (line_no, ERR_e, 
(long)EQUIV_) ; 

if ( ! ByPass (EQUIV_) ) 

ErrorHandler (line_no, ERR_f , 
(long) KW_+AND_) ; 
else  if  (  (QualExpU  (  (*root)  ->rptr)  ) 

!=TRUE) ) 


/*  looking  for  ID  == 

/*  found  '=='  It's  a  DATADEr 

/*  attach  temp  ptr  to  root 

/»  now  need  QualExp 

/*  note, try  &  fix 


/*  end  ByPass  EQUIV_ 

/*  looking  for  ID  :  TYPEEXP 

/*  found  :  so  it's  a  KINDEF 

/*  attach  temp  ptr  to  root 

/*  now  need  TypeExp 

/*  note, try  to  fix 


/*  end  else  if  ByPass  : 

/*  not  ==  or  :,  so  must  be 

/*  ID  FORMALS 

/*  will  look  for  ID  FORMALS 

/*  attach  ID  to  FUNID 

/*  need  the  FORMALS 

/*  note  it, try  S  fix 


/*  Look  for  '==', already  created 

/*  FUNAUXDEF  -  Need  QualExp  on  rt  */ 

/*  note, try  s  fix  */ 
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ErrorHandler (line_no, ERR_c, 
(long) KW  +AND  ) 


/*  note  it, try  &  fix 
/*  end  else  not  '==■  or 


goto    CHECK; 


} 


/*    found   something    so   need  to  */ 

/*    check    for    more  */ 

/*    end    if    ID  */ 


/******        didn't    find    ID,    so    look    for 

else    if (((flag    =    Formals ( root ) )     !=    FALSE)) 
(       if (flag==ERROR_) 

ErrorHandler ( line_no, ERR_e, 
(long) EQUIV_) ; 
if (ByPass(EQUIV_) ) 
(       MakeNewRoot  (  root , DATADEF, LEFT) ; 

if ( (QualExp(S (  (*root) ->rptr)  )  !=TRUE) ) 

ErrorHandler ( line_no, ERR_c, 
(long) KW_+AND_) ; 
}else 

ErrorHandler (line_no, ERR_f , 
(long)KW_+AND_) ; 
goto    CHECK; 


FORMALS    ==    QUALEXP 

/*    found   something 

/*    note,    try    4    fix 

/*  looking  for  == 

/*  found  ==,  so  fix  tree 

/*  need  QualExp  on  rt 

/*  note, try  S  fix 


/*  end  if  ByPass (EQUIV) 
/*  note, try  to  fix 


****** 


*/ 


/*  found  somenthig  so  check  for    */ 
/*  more  defs  */ 


/*****     nothing  so  far   -   look  for  some  sort  of  TYPEDEF     *****/ 


else  if (ByPass (KW_  +  TYPE_) ) 
{    if(id_ptr  =  ByPass ( IDENTIFIERJ ) 
{  temp  =  CreateNode ( IDENTIFIER_) ; 
temp  ->index  =  id_ptr; 


/*  found  TYPE,  looking  for  ID     */ 
/*  set  up  It  side  of  subtree      */ 


if (ByPass (EQUIV_) ) 

(   "root  =  CreateNode (TDEFID) ; 

(  *root ) ->lptr  =  temp; 
)else 
(   if ( (Formals (root)  !=  TRUE)) 

ErrorHandler ( line_no, ERR_e, 
(long) EQUIVJ ; 
MakeNewRoot (root, FUNID, RIGHT) ; 
(•root)  ->lptr  =  temp; 
if  (  ! ByPass (EQUIV_) ) 

ErrorHandler (line_no, ERR_f , 
(long)KW_+AND_) ; 
MakeNewRoot (root, TDEFFUN, LEFT) ; 
} 
if ( (TypeExptS ( (*root) ->rptr) ) !=  TRUE) ) 

ErrorHandler (line_no,  ERR_d, 
(long) KW_+AND_) ; 
> 
else 

ErrorHandler (line_no, ERR_g, 
(long)KW_+AND_) ; 
goto  CHECK; 


return  ( flag) ; 


/*  found  ID,  looking  for  == 

/*  found  ==  so  it's  a  TDEFID 

/*  not  ' == '  yet 

/*  note  it, try  to  fix 


/*  found/fixed  '==',fix  tree 

/*  end  else  not  '=='  yet 

/*  need  TypeExp  on  rt 

/*  note, try  &  fix 


/*  end  if  ByPass  ID 

/*  no  ID, note  it, try  to  fix 


/*  found/fixed  Formals, fix  tree  */ 
/*  attach  ID  to  FUNID  node  */ 
/*  note  it, try  to  fix  */ 


/*  found  sometthing  so  check  for   */ 
/*  more  defs  */ 

/*  end  ByPass  TYPE  */ 


/*  default  -  none  of  the  above 


■ 


80 


CHECK:  /*  found  something  so  need  to      */ 

/*  check  for  more  clef's  */ 

Def And (root ) ; 

return (TRUE) ;  /*  any  errors  have  been  notea,     */ 

/*  so  press  on  */ 

}  /*  end  Defs  */ 

/******•*************************************************•*****•*******/ 

void 
DefAnd(root)  /*    root    is    a   ptr    to    tree/subtree      */ 

NodeRec         **root;  /*    currently    working   with  */ 

/*                                                                           <DEFAND>  : :=    and    <DEFS>  */ 

/*                                           Where    "    and  <DEFS>  "    need   not    be   present.  */ 

/*                  Note:       This    function    assumes  root    is    not    NULL   upon   entry  */ 
{ 

if (ByPass (KW_    +    AND_) ) 

{   MakeNewRoot (root, DEFAND, LEFT)  ;               /*  found  "and"  so  fix  tree  */ 
if (Defs (S (*root) ->rptr)  !=  TRUE) 
ErrorHandler (line_no, ERR_h, 

(long) SEMI_) ;                 /*  note  it,  try  to  fix  */ 

)                                               /*  end  ByPass  AND  -/ 

}                                                /*  end  DefAnd  */ 

/•••••••••••a**********************************************************/ 

int 
QualExp ( root )  /*    root    is    a   ptr    to    tree/subtree      */ 

NodeRec         **root;  /*    currently   working   with  */ 

/*  <QUALEXP>     ::=    <EXPRESSION>    where    <AUXEXP>  */ 

/*  Where    "where   <AUXEXP>"    need  not   be   present.  */ 

{ 

int  flag; 

#ifdef  DEBUG 

print f("  qualexp  entered\n") ;    scanf  ( "%*c") ; 

#endif 

if (((flag  =  Expression (root) ) ==  ERROR_) )  /*  errors  already  reported,  */ 

EatEm(KW_+END_) ;  /*  attempt  to  press  on  */ 

if (ByPass (KW_+  WHERE_) )  /*  looking  for  where  expression  */ 

(   MakeNewRoot (root, (KW_+WHERE_) , RIGHT) ;  /*  found  one, fix  tree  */ 

AuxExp(& ( (*root) ->lptr) ) ;  /*  need  AuxExp  following  WHERE  */ 

}  /*  end  byPass  WHERE  */ 

#ifdef  DEBUG 

printfC  qualexp  exited    %d\n",  f  lag)  ; 

scanf ("%*c") ; 
fendif 

return ( flag) ;  /*  default  -  just  return  flag      */ 

}  /*  end  Qualexp ()  */ 

/*****•*********•*********•*****••*•***********••*****•*******•********/ 

int 
AuxExp(root)  /*  root  is  a  ptr  to  tree/subtree   */ 

NodeRec    "root;  /*  currently  working  with         */ 

/*  <AUXEXP>  ::=  <AUXDEFS>  (where  <AUXEXP>) *  */ 
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int 


flag; 


if ( ( (flag  =  AuxDefs (root) ) !=  TRUE) ) 
Error Handler (line_no, ERR_i, 

(long) KW_+WHERE_) ; 

if (ByPass (KW_+  WHERE_) ) 

{   MakeNewRoot (root, (KW_  +  WHERE_) , RIGHT) ; 
AuxExp (S  ( (*root) ->lptr) ) ; 


/*  need  at  least  one  AUXDEF        */ 
/*  note,  try  &  fix  */ 


/*  looking  for  multiple  WHERE'S  */ 

/*  found  one, fix  tree  */ 

/*  need  AuxExp  following  WHERE  */ 

/*  end  ByPass (WHERE)  */ 


return ( flag) ;  /*  default  -  return  result  of     */ 

/*  first  AuxDefs  */ 

}  /*  end  AuxExp  */ 

/******•*****************•*•**************•***************************•/ 


int 
AuxDefs ( root ) 
NodeRec 


'root ; 


/*    root    is    a   ptr    to   tree/subtree 
/*    currently   working   with 


/* 

/* 

( 

NodeRec 
int 
long 


<AUXDEFS>  ::=  (<DATAAUAXDEF>  |  <FUNAUXDEF>)  <AUXAND> 
Where  "<AUXAND>  "  need  not  be  present. 


*temp; 

flag; 

ptr; 


*/ 
*/ 

*/ 
*/ 


/*  address  of  data  struct  holding  */ 
/*  identifier  name  */ 


if ((ptr  =  ByPass (IDENTIFIER^ ) ) 
{    temp  =  CreateNode(IDENTIFIER_) ; 
temp  ->index  =  ptr; 


/*  set  up  its  side  of  subtree 


if (ByPass (EQUIV_) ) 

{   "root  =  CreateNode(DATAAUXDEF) ; 
(•root) ->lptr  =  temp; 

if (Expression (& ( (*root) ->rptr) ) ! =  TRUE) 
Error Handler (line_no, ERR_c, 

(long) KW_+WHERE_) ; 
} 

else 
(   'root  =  CreateNode(FUNAUXDEF) ; 

(•root)  ->lptr  =  CreateNode (FUNID) ; 
(•root)  ->lptr->lptr  =  temp; 
if  (  (Formals (& (*root) ->lptr->rptr) 
!=  TRUE) ) 
Error Handler (line_no, ERR_e, 
(long) EQUIV_) ; 


if ( ! ByPass (EQUIV_) ) 

ErrorHandler (line_no, ERR_f , 

(long)KW_+WHERE_) ; 
else 

if  (  (Expression (S ( ( *root ) ->rptr) ) 
!=  TRUE) ) 
ErrorHandler ( line_no, ERR_c, 

(long)KW  +WHERE  ) 


goto  CHECK; 


/*  looking  for  ID  ==  */ 

/*  found  '=='  It's  a  DATAAUXDEF  */ 

/*  attach  temp  ptr  to  root  */ 

/*  now  need  Exp  */ 

/*  noteit,  try  &  fix  */ 

/*  end  ByPass  EQUIV_  */ 

/*  not  '=='  so  must  be  ID  FORMALS  */ 


/*  will  look  for  ID  FORMALS 

/*  attach  ID  to  FUNID 

/*  need  the  FORMALS 

/*  note,  try  to  fix 

/*  Looking  for  '==', already 

/•  created  FUNAUXDEF  - 

/*  need  QualExp  on  rt 

/*  note  the  errors,  try  &  fix 


/•  end  else  not  ' == ' 

/ *  found  something  so  need  to 

/*  check  for  more 

/*  end  if  ID 
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/ 


****** 


didn't  find  ID,  so  look  for  FORMALS  ==  EXP 


*********** 


if(((flag  ='  Formals  (root)  )  !=  FALSE)) 
{   if (flag==ERROR_) 

ErrorHandler (line_no, ERR_e, 
(long)EQUIVJ ; 
if (3yPass(EQUIV_) ) 

{   MakeNewRoot (root , DATAAUXDEF, LEFT) ; 
if ( (Expression (& ( ('root) ->rptr) ) 
!=  TRUE) ) 
ErrorHandler (line_no,  ERR_c, 

(long) KW_+WHERE_) ; 
)else 

ErrorHandler ( line_no, ERR_f , 

(long)KW_+WHERE_) ; 

goto  CHECK; 

} 

return ( flag)  ; 

CHECK: 

AuxAnd (root) ; 

return (TRUE) ; 


/*  found  something 

/*  note,  try  S  fix 

/*  looking  for  == 

/*  found  ==,  so  fix  tree 

/*  need  Exp  on  rt 

/*  note, try  fix 


/*  found  somenthig  so  check  for 

/*  more  auxdefs 

/*  default  -  none  of  the  above 

/*  found  something  so  need  to 

/*  check  for  more  def's 


/ 


/*  any  errors  have  been  noted,     */ 

/*  so  press  on  */ 

/*  end  AuxDefs  */ 

••a*******************************************************************/ 


void 
AuxAnd (root! 
NodeRec 

/* 
/* 
/* 

{ 


root; 


/*    root    is    a   ptr    to    tree/subtree 
/*    currently   working   with 


<AUXAND>    ::=    and   <AUXDEFS> 
Where    "and   <AUXDEFS>"    need   not    be   present. 
Note:       This    function   assumes    root    is    not    NULL   upon   entry 


/*    found    "and"    so    fix   tree 
/*    note    it,    try    &    fix 


if (ByPass (KW_+AND_) ) 

{   MakeNewRoot ( root , AUXAND,  LEFT)  ; 

if  (  (AuxDefs (& (*root) ->rptr)  !=  TRUE)) 
ErrorHandler (line_no, ERR_h, 

(long)KW_+WHERE_) ; 
}  /*  end  ByPass  AND 

)  /*    end  AuxAnd 

/a*********************************************************************/ 

int 
Formals (root) 

NodeRec    **root; 


/*  root  is  a  ptr  to  tree/subtree 
/*  currently  working  with 


/* 

( 
NodeRec 


long 


<FORMALS> 
*temp,  *workingroot ; 

ptr; 


=  <ID> 


(  '  <FORMALS> 


I    I    I  \  1 
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/*  temp  ptrs  to  nodes  in  tree 
/*  workingptr  marches  down  the 
/*  rt  side  of  the  subtree 


if  ((ptr  =  ByPass (IDENTIFIER^) ) ) 
{   *rcot  =  CreateNode( IDENTIFIER^ ; 
(*root)  ->index  =  ptr; 

return (TRUE) ; 


/*  checking  for  just  an  ID 
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} 


if (ByPass (LTPARENJ ) 

{   'root  =  CreateNode (FORMAL) ; 

if ( ( Formal s (S (  (*root) ->lptr)  )  ! =TRUE)  ) 
ErrorHandler (line_no, ERR_e, 
(long)RTPAREN_) ; 

workingroot  =  (*root); 

while (ByPass (COMNA_) ) 

(   workingroot  ->rptr=CreateNode (COMMA_) 
temp  =  workingroot->rptr; 
if ( ( Formal s (& (temp->lptr) )  !=TRUE) ) 

ErrorHandler (line_no, ERR_e, 
(long) RTPAREN_) ; 
workingroot  =  workingroot->rptr; 
} 

if (ByPass (RTPARENJ ) 

{   if(*root  ==  workingroot) 
(   "root  =  (*root) ->lptr; 

free (workingroot ) ; 
) 

return (TRUE) ; 
} 

ErrorHandler ( line_no, ERR_ j, NULL) ; 
return (ERROR_) ; 
) 
return (FALSE) ; 


/*  end  if  ByPass  ID  */ 

/*  checking  for  '('  FORMALS  ')'    */ 

/*  recursive  search  */ 

/*  note  it, try  &  fix  */ 


/*  set  the  working  ptr  for  later  */ 

/*  use  */ 

/*  have  '('  FORMALS  now  looking  */ 

/*  for  ',  '  */ 

/*  found  ', '  attach  it  to  rt  side  */ 

/*  recursive  search  */ 

/*  need  FORMALS  following  ','  */ 

/*  note  it, try  &    fix  */ 


/*  end  while  ByPass  COMMA 


</ 


/*  looking  for  ') '  already  found  */ 

/*  ' ( '  FORMALS  */ 

/*  compact  the  tree  -  only  one  ID  */ 

/*  end  of  compaction  */ 

/*  end  of  compaction  */ 

/*  end  if  RTPAREN  */ 

/*  missing  ')'  after  '('  */ 

/*  end  if  ByPass  LTPAREN  */ 

/*  default  -  none  of  the  above  »/ 

}                                               /*  end  Formals ()  */ 
/•a********************************************************************/ 


int 
Expression (root) 

NodeRec    **root; 


/*  root  is  a  ptr  to  tree/subtree   */ 
/*  currently  working  with         */ 


I 


<EXPRESSION>  ::=  <CONJUNCTION>  (  \/  <EXPRESSION>) * 


int     flag; 

if (((flag  =  Con  junction (root) )  ==  TRUE)) 

if (ByPass (ORLOG_) ) 

{   MakeNewRoot (root, ORLOG_, LEFT) ; 

if ( (Expression (& ( (*root) ->rptr) ) !=TRUE) 
(   ErrorHandler (line_no, ERR8, 
(long)ORLOGJ  ; 
return (ERROR_) ; 
} 

} 

return ( flag) ; 


/*  look  for  Conjunction 

/*  will  recursively  check  for  \/ 

/*  found,  so  fix  root  for  return 

/*  A  w/o  following  Exp. 

/*  Just  note  it,  no  fix 


/*  end  recursive  search 


/*  end  Expression!) 


/••A*******************************************************************/ 
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/•••A******************************************************************* 


*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 


PUBLIC  DOMAIN  SOFTWARE 
parser  pt  2 
parser2 . c 

Maj  E.J.  COLE  /  Capt  J.E.  CONNELL 
10/20/86 
12/11/86 
01/27/87  -  Error  Recovery  added.    JC 


************************************************************************ 

*  This  file  contains  the  following  modules  for  the  PHI  parser:  * 

*  Con  junction  ()    Negation  ()       Relation  ()       Relator  () 

*  SimplExpO       AddOpO  MullOPO         Term() 

*  Factor ()         Primary ()        Application ( )    Actual () 


*  Algorithm  :   See  parser  part  1 


************************************************************************ 

*  Modified         :       12/26/86    Flattened   tree    output    changed   to    abstract  * 

*  syntax   tree    form.    JC  * 

*  :       01/10/87    Corrections    to    comply   with    latest    definitions    * 

*  of    the    language.    JC  * 

*  :       01/27/87    Error   Recovery   added   and    files    combined.    JC         * 
•••••••••a*************************************************************/ 

♦include    <stdio.h> 
♦include   <parser.h> 

extern    int         line_no;  /*    global   var,    holds    current    line    */ 

/*    no    of    source   prog  */ 

extern    int         rtbrket;  /*    global    flag    -    aids    in    making        */ 

/*    PHI    deterministic  */ 

/•••••••A**************************************************************/ 


int 
Conjunction (root) 

NodeRec    **root; 


/* 
{ 

int    flag; 


<CONJUNCTION> 


/*  root  is  a  ptr  to  tree/subtree 
/*  currently  working  with 

<NEGATION>  (  /\  <CONJUNCTION>) * 


if  ((flag  =  Negation (root) )  ==  TRUE) 

if  (ByPass (ANDLOGJ ) 

{   MakeNewRoot ( root , ANDLOG_, LEFT) ; 

if  (Con  junction  (S ( (*root) ->rptr) )  !=  TRUE) 
(   ErrorHandler (line_no, ERR8, 

(long) ANDLOGJ ;/* 
return (ERROR  ) ; 


> 


} 


/*  look  for  Negation  part  */ 

/*  will  recursively  check  for  A   */ 

/*  found,  fix  root  for  return  */ 

/*  A  w/o  following  Neg .  */ 

/*  Just  note  it,  no  fix  */ 


/*  end  recursive  search 


return ( flag) ; 


/*  end  Con  junction ( ) 


/a*********************************************************************/ 


int 
Negation (root) 

NodeRec    "root; 


/*  root  is  a  ptr  to  tree/subtree   */ 
/*  currently  working  with         */ 
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I- 


<NEGATION> 


<RELATION> 


I 


if  (ByPass  (NEGLOGJ  ) 
(   'root  =  CreateNode (NEGLOG_) ; 
if  (Relation (S (  (*root) ->rptr)  ) 
{   ErrorHandler (line_no,  ERR8, 
(long) NEGLOG_) 
return (ERROR  ) ; 


TRUE) 


/*  look  for  -  */ 

/*  found  a  -  */ 

/*  ~  w/o  Relation.  Just  note  it    */ 

/*  note  it,  no  fix  */ 


else    return (TRUE) ; 


return (Relation (root) 


********************************************************************** 


/*  end  if  NEGLOG  */ 

/*  just  check  for  single  relation  */ 
/*  end  NEGATION  */ 

/ 


int 

Relation ( root ) 

NodeRec    **root; 


/*  root  is  a  ptr  to  tree/subtree 
/*  currently  working  with 


/* 
/* 

{ 

int    flag,  type; 

if ((flag    =    SimplExp(root) )     ==   TRUE) 


<RELATION>     ::=         <SIMPLEXP>     (    <RELATORXSIMPLEXP>)  * 
Where    <RELATOR><SIMPLEXP>   need   not    be   present 

/*    type    is    kind   of    relator    found 


*/ 
*/ 

*/ 

*/ 


if(argbind  &S  IBall (RTBRAKET_, 2 ) ) 

return ( flag) ; 
else  if  (type  =  Relator  0  ) 
( 

MakeNewRoot (root , type, LEFT) ; 

if (SimplExp (& ( (*root) ->rptr) ) !=  TRUE) 

{   ErrorHandler (line_no, ERR8, 
(long) type) ; 
return (ERROR_) ; 

} 
} 
return ( flag) ; 


/ 

/*  looking  for  a  Term.   Need  to  */ 

/*  look  ahead  for  ' ] '  due  to  poss  */ 

/*  of  having  been  called  from  */ 

/*  ArgBindO  &  ArgBindO  looking  */ 

/*  for  "  <QualExp><Op> ' ] '  "  */ 

/*  following  first  <Op>  */ 


/*  recursively  check  for  more     */ 

/*  RELATION'S  */ 

/*  found  one,  fix  root  for  return  «/ 

/*  RELATOR  w/o  SimpExp.  Just  note  */ 

/*  note  it,  no  fix  */ 


/*  end  recursive  search 


}  /*  end  RELATION  */ 

1**********************************************************************1 


int 
Relator () 


<RELATOR>  ::=     =  I  <>  I  <  I  >  I  <=  I  >=  I  in  I  notin 
Note:    returns  the  Relator  value  vice  TRUE  if  found 


flag; 


if  (  (flag=ByPass (EQ_) ) ) 

else  if ( (flag=ByPass (NEQ_) ) ) 

else  if  (  (flag=ByPass (LEQ_)  )  ) 

else  if  (  (flag=ByPass (GEQ_) ) ) 

else  if  (  (flag=ByPass (KW_+IN_) )  ) 

else  if (  (  f lag=ByPass (KW_+NOTIN_) )  ) 

else  if ( (flag=ByPass (KW_+LESS_) ) ) 

else  if  (  (flag=ByPass (KW_+GREATER_) )  ) 


/*  do  nothing 


*/ 

*/ 
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return ( flag) ;  /*  return  result  of  search        */ 

}  /*  end  Relator  */ 

/a*********************************************************************/ 


int 
SimplExp(root) 

NodeRec         **root; 


/ 


<SIMPLEXP> 


( 

int         flag,    type; 

if ( (flag=Term(root) ) ==  TRUE) 
if(argbind  &&  IBall (RTBRAKET_, 2) 
return (flag) ; 


else  if (type=AddOp() ) 

{   MakeNewRoot (root, type, LEFT) ; 

if  (SimplExpU (  (*root) ->rptr)  )  !=  TRUE) 
{    ErrorHandler (line_no,  ERR8, 
(long) type) ; 
return (ERROR_) ; 
} 


/*  root  is  a  ptr  to  tree/subtree  * / 

/*  currently  working  with  */ 

<TERM>  (  <ADDOPXSIMPLEXP>)  *  */ 

/*  type  is  kind  of  relator  found  */ 


/*  looking  for  a  Term 

/*  Need  to  look  ahead  for 


*/ 

due  */ 


} 

return ( flag) ; 


/*  to  possibility  of  having  been 

/*  called  from  ArgBindO  and 

/*ArgBind  looking  for  <QualExp> 

/*  <0p>  ']'  following  <0p> 

/*  recursively  check  for  more 

/*  SIMPLEXP's 

/*  found  AddOp,  so  fix  root  for 

/*  return 

/*  AddOp  w/o  SimpExp.  Note  it 

/*  note  it,  no  fix 


/*   end    recursive    search 


/*    end    SimplExp 


/•••••A****************************************************************/ 

int 
AddOp ( ) 


/* 
/* 

{ 

int         flag; 


<ADDOP>    : :=  +     I     -     I     :     I     " 

Returns    the   AddOp   value    vice    TRUE    if    found 


*/ 
*/ 


if  (  (  f lag=ByPass (ADD_) ) ) 
else        if ( (flag=ByPass (SUB_) ) ) 
else        if ( (flag=ByPass (COLONJ ) ) 
else        if { (flag=ByPass (CAT_) ) ) 

return ( flag) ; 


/*   do   nothing 


/*    return    result    of    search 
/*    end   AddOo 


/••••a************************************************** 


int 
MulOp () 

/* 
/* 

( 

int         flag; 


<MULOP>    : :=         *     I     /     I     %     (idiv) 
Returns    the   MulOp   value   vice   TRUE    if    found 


if  (  (flag  =  ByPass (MULT_) ) ) 

else        if ( (flag=ByPass (RDIV_) ) 

else        if (  (flag=ByPass (IDIV    ) ) 


/*   do    nothing 


*/ 
*/ 
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return ( flag) ;  /*    return    result    of    search  »/ 

}  /*    end   Relator  «/ 

/it*********************************************************************/ 


int 
Term (root) 

NodeRec         **root; 


I- 


<TERM> 


int         flag,    type; 

if ((flag    =    Factor (root) 


/*    root    is    a   ptr    to   tree/subtree  */ 

/*   currently  working  with  */ 

<FACTOR>     (    <MULOPXTERM>    )  *  */ 

/*    type    is    kind   of    relator    found  */ 


TRUE) 


if(argbind  &S  IBall (RTBRAKET_, 2 )  ) 

return ( flag) ; 
else  if  (type  =  MulOpO) 

{   MakeNewRoot (root, type,  LEFT)  ; r 

if (TermtS ( (*root) ->rptr) )  !=  TRUE) 
{   ErrorHandler (line_no,  ERR8, 
(long) type) ; 
return (ERROR_) ; 
} 
) 
return ( flag) ; 


/*  looking  for  Factor  */ 

/*  Need  to  look  ahead  for  '] '  due  */ 

/*  to  possibility  of  having  been   */ 

/*  called  from  ArgBindO  &  ArgBind*/ 

/*  looking  for  <QualExp>  <0p>      */ 

/*  '] 'following  <Op>  ?  */ 

/*  will  recursively  look  for      */ 

/*  more  TERM' s  */ 

/*  fnd  MulOp,  so  fix  root  for  rtn  */ 

/*  MulOp  w/o  following  Term.       */ 

/*  note  it,  no  fix  */ 


/*  end  recursive  search 


}  /*  end  Term  */ 

/••••••a***************************************************************/ 


int 
Factor (root) 

NodeRec    **root; 


/ 


<FACTOR> 


/*  root  is  a  ptr  to  tree/subtree   */ 
/*  currently  working  with         */ 


[+| -]<PRIMARY> 


/*  check  for  ' +■  or 


if  (status  =  ByPass (ADD_) ) 

"root  =  CreateNode (POS_)  ; 
else  if (status  =  ByPass (SUB_) ) 

'root  =  CreateNode (NEG_)  ; 

if  (status) 

if (Primary (S ( (*root) ->rptr) ) !=TRUE) 
{   ErrorHandler (line_no, ERR8, 
( long) status) ; 
return (ERROR_) ; 
) 
else    return (TRUE) ; 
else    return (Primary (root) ) ; 


/*  found  ' +'  or  ' - ' 

/*  MulOp  w/o  following  Term. 

/*  note  it,  no  fix 


/*  default,  check  for  Primnary 
/*  end  FACTOR 


/*******•******************************************•***•*****•******•**/ 


int 
Primary ( root) 

NodeRec    **root; 


/*  root  is  a  ptr  to  tree/subtree   */ 
/*  currently  working  with         */ 


/* 
{ 


<PRIMARY> 


<APPLICATION>  (!<PRIMARY>) 


88 


int       flag; 

if (flag  =  Application (root ) ) 


if(argbind  &S  IBall (RTBRAKET_,  2 )  ) 

return ( flag) ; 
else  if  (ByPass (SUBSCRIPT^) ) 

{   MakeNewRoot ( root , SUBSCRIPT_,  LEFT) 
if  (  ! Primary (S ( (*root) ->rptr) ) ) 
{   ErrorHandler (line_no,  ERR8, 

(long)SUBSCRIPT_) ; 
return (ERROR_) ; 
} 
} 
return ( flag) ; 


/*  looking  for  an  Application  */ 
/*  Need  to  look  ahead  for  '  ]'  */ 
/*  due  to  possibility  of  having    */ 


/*  been  called  from  Arg3ind() 

/*  and  *ArgBind()  looking  for 

/*  <QualExp><0p>  ' ] '  following 

/*  recursively  look  for  next 

/*  Application 

/*  found  one  so  fix  tree 

/*  ' ! '  w/o  following  Primary. 

/*  note  it,  no  fix 


/*  end  recursive  search 


/*  end  Primary () 


a********************************************************************* 


int 
Application (root ) 
NodeRec    **root; 


/*  root  is  a  ptr  to  tree/subtree   */ 
/*  currently  working  with         */ 


/* 

{ 

int  flag; 

NodeRec         *tnode; 


<APPLICATION> 


(<ACTUAL>) + 


/*   temp   pointer   to 


node 


if ((flag  =  Actual (root) )  ==  TRUE) 

if ((flag  =  Application (Stnode)  )  ==  TRUE) 

{   MakeNewRoot ( root , ACTUALLIST, LEFT) ; 

(•root)  ->rptr  =  tnode; 

if ( ("root) ->rptr->name  !=  ACTUALLIST) 
MakeNewRoot (& ( (*root) ->rptr) , 
ACTUALLIST, LEFT) ; 
} 
else  if (flag  ==  ERROR_) 

ErrorHandler (line  no, ERR  k,NULL); 


/*  look  for  an  actual 

/*  look  for  an  actual  list 


/*  fix  tree  so  all  Actual's 

/*  hang  to  LEFT  */ 

/*  end  if (Application ( it  node) 

/*  invalid  ActualList 

/*  note  it,  no  fix 


-/ 

*/ 
*/ 


/*    either   valid   ActualList    or  */ 

/*    just    a    single    actual  */ 

/*    return    ERROR_   or    FALSE,  */ 

/*   based   on    first    look  */ 

/*   end   Application ( )  */ 

•••••A****************************************************************/ 


else    return (TRUE) ; 
return ( flag) ; 


int 
Actual ( root) 

NodeRec         **root; 


/* 
/* 


<ACTUAL> 


/*    root    is    a    ptr    to   tree/subtree      */ 
/*    currently   working   with  */ 


<ID> |     f ile<LITERAL> | <CONDITIONAL> | <BLOCK> | 
<DENOTATION> | <COMPOUND> | <ARGBINDING> 


*/ 
*/ 


{ 

long  ptr; 

NodeRec  'temp; 

int  flag; 


/*  ptr  to  data  struct  holding  the  */ 
/*  actual  value  of  ID,  REAL,  etc  */ 
/*  ptr  to  temp  node  in  the  tree    */ 


if  ((ptr  =  ByPass (IDENTIFIER  ))) 


/*  checking  for  ID 
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"root  =  CreateNode (IDENTIFIERJ ; 
(♦root)  ->index  =  ptr; 

if (ByPass (LINERTARROW_) ) 
{ 

MakeNewRoot (root, LINERTARROW_, LEFT) ; 
if (Actual (&( (♦root) ->rptr) )  ==  TRUE) 

return (TRUE) ; 
else 
{   ErrorHandler ( line_no, ERR8, 

(long) LINERTARROWJ ; 
return (ERRORJ ; 
) 
) 
return (TRUE) ; 


if  (  ByPass (KW_  +  FILEJ  ) 
(   ♦root  =  CreateNode (KW_  +  FILE_) ; 
if  ((ptr  -  ByPass (LITERAL_) ) ) 
{   temp  =  CreateNode (LITERAL_) ; 

temp  ->index  =  ptr; 

(♦root)  ->rptr  =  temp; 

return (TRUE) ; 
) 

else 
{   ErrorHandler ( line_no, ERR_1,  NULL) 

return (ERROR_) ; 
} 


if  ((flag  =  Conditional (root) )  !=  FALSE) 

return  ( flag) ; 
if  ((flag  =  Block  (root))  !=  FALSE) 

return ( flag) ; 


/♦  now  look  for  ID  I ->  ACTUAL 

/*  Note:  "ID  I ->  ACTUAL"  is  a 

/♦  <DENOTATION> 

/♦  found  one  so  fix  tree 

/♦  look  for  trail  ACTUAL 

/♦  note  it,  no  fix 


/♦  end  else  not  Actual () 

/♦  end  if  LINERTARROW 

/*  end  if  ID 

/♦  found  keyword  FILE 

/♦  attach  following  LITERAL 


/*  end  if  LITERAL_ 
/♦  note  it,  no  fix 


/♦  end  if  FILE 


if  ((flag  =  Compound ( root ) )  ==  TRUE) 

if ( ! ByPass (LINERTARROWJ )    return (TRUE) 

else 

{   temp  =  ♦root; 

if ( ! IsFormal (temp) ) 

ErrorHandler (line_no, ERR_o, NULL) ; 
(  ♦root) ->name  =  FORMAL; 
MakeNewRoot (root, LINERTARROW_, LEFT) ; 
if (Actual (&( (♦root) ->rptr) )  ==  TRUE) 

return (TRUE) ; 
else 
(   ErrorHandler (line_no, ERR8, 

( long) LINERTARROWJ ; 

return (ERROR  ) ; 


/♦  Phi  is  nondeterministic  must    ♦/ 

/♦  first  check  for  compounds  then  ♦/ 

/♦  if  I ->  follows  must  see  if  the  ♦/ 

/♦  compound  was  actually  a  fcrmaisV 

/♦  list   NOTE:   Order  may  NOT  be   ♦/ 

/♦  changed ! !  ♦/ 


/♦  had  "l->"   now  need  to  see  if  ♦/ 

/♦  had  Formals  ♦/ 

/♦  set  var  to  be  passed  by  value  ♦/ 

/♦  to  IsFormals  ♦/ 

/♦  just  report  it  and  press  on  ♦/ 


/♦  found  one  so  fix  tree 

/♦  look  for  trail  ACTUAL 

/♦  note  it,  no  fix 


else  if (flag  ==  ERROR J 
return (ERROR  ) ; 


/♦  end  else  ByPass  LINERTARROW 
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if  ((flag  =  Denotation (root) )  !=  FALSE) 
return  ( flag) ; 

if  ((flag  '=  ArgBinding(root) )  !=  FALSE) 
return ( flag) ; 

return (FALSE) ;  /*  Default,  tried  everything  else  */ 

}  /*  end  Actual ()  */ 

/•••••••a**************************************************************/ 
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*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 


Arm() 

BlockO 

Compound ( ) 

* 

Denotation ( ) 

ArgBindO 

opo 

* 

TypeDomO 

TypeTermO 

TypeFac  () 

* 

PrimType ( ) 

* 

*  PUBLIC  DOMAIN  SOFTWARE  * 
parser  pt  3  * 
parser3 .c  * 
Maj  E.J.  COLE  /  Capt  J.E.  CONNELL  * 
10/20/86 

12/11/86  * 

01/27/87  -  Error  Recovery  added.    JC  * 

************************************************************************ 

*  This  file  contains  the  following  modules  for  the  PHI  parser:  * 

*  Conditional ( ) 

*  Elements () 

*  TypeExpO 

*  TypePrimary ( ) 

*  * 

*  Algorithm  :   See  parser  part  1  * 

*  * 
************************************************************************ 

*  Modified         :       12/26/86   Flattened  tree   output    changed  to   abstract  * 

*  syntax   tree    form.    JC  * 

*  :       01/10/87    Corrections    to    comply   with    latest    definitions    * 

*  of    the    language.    JC  * 

*  :       01/27/87    Error   Recovery   added  and   files   combined.    JC  * 
***********************************************************************/ 

♦include    <stdio.h> 
♦include    <parser.h> 

extern    int         rtbrket;                                                                        /*   global    flag   -    aids    in  */ 

/*   making   PHI    deterministic  */ 

extern    int         line_no;                                                                        /*   global   var,    current    line  */ 

/*    number   of    program  */ 

/**********************************************************************/ 

int 

Conditional ( root )                                 /*  root  is  a  ptr  to  tree/subtree  */ 

NodeRec    **root;                              /*  currently  working  with  */ 

/*   <CONDITIONAL>  ::=  if  <ARM>  (elsif <ARM>) *  (else<EXPRESSION) 1  endif  */ 

{                                                  /*  ptrs  to  temp  nodes  in  the  tree  */ 
NodeRec    *temp  =  NULL,  *subroot,  'workingptr; 

if (ByPass (KW_  +  IF_) ) 

(   if  (Arm(Stemp)  !=  TRUE) 

IrrorHandler (line_no, ERR_m, (long) IF_) ;    /*  note  it,  try  to  fix  */ 

'root  =  CreateNode (KW_  +  IF_) ;               /*  set  up  root  for  return  */ 

("root)  ->lptr  =  temp;                       /*  attach  THEN  exp  to  root  */ 

workingptr  =  "root;                         /*  move  working  ptr  */ 

while (ByPass (KW_  +  ELSIF_)) 

subroot  =  CreateNode (KW_  +  ELSIF_) ; 

workingptr  ->rptr  =  subroot;              /*  attach  ELSIF  to  tree  */ 

if (Arm(Stemp)  !=  TRUE) 

ErrorHandler (line_no, ERR_m,            /*  note  it, try  &  fix  */ 
(long) ELSIFJ ; 

subroot  ->lptr  =  temp;                    /*  attach  THEN  exp  to  ELSIF  */ 

workingptr  =  workingptr  ->rptr;           /*  move  wrking  ptr  down  subtree  */ 

}                                          /*  end  while  ELSIF  */ 
if (ByPass ( KW_  +  ELSE_) ) 
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{   if (Expression (Stemp)  !=  TRUE) 

ErrorHandler (line_no, ERR_m,  /*  note  it,  try  &  fix  */ 
(long) ELSE_) ; 
subroot  =  CreateNode (KW_  +  ELSE_) ; 

workingptr  ->rptr  =  subroot;  /*  attach  ELSE  to  tree  */ 

subroot  ->lptr  =  temp;  /*  attach  EXPRESSION  to  ELSE  */ 

workingptr  =  workingptr  ->rptr;  /*  move  wrking  ptr  down  subtree  */ 

}  /*  end  ELSE  */ 

if (ByPass(KW_  +  ENDIFJ ) 

(   temp  =  CreateNode (KW_  +  ENDIFJ ; 

workingptr  ->rptr  =  temp; 

}else  /*  note  it  and  try  to  fix  -  */ 

{  ErrorHandler (line_no, ERR_n,  NULL)  ;  /*  will  return  TRUE  regardless  */ 

if (IBall(ENDIF_, 1)  II  IBall(ENDIF_,2) )     /*  look  2  ahead  for  the  END  */ 

Eat£m(ENDIF_) ; 

}  /*  end  else  not  ByPass  ENDIF_  */ 

return (TRUE) ;  /*  saw  an  IF,  any  errors  they  */ 

/*  were  already  reported  */ 

)  /*  end  if  IF  */ 

return (FALSE) ;  /*  didn't  see  an  IF  */ 

}  /*  end  Conditional ( )  */ 

/**********•**********•*•******************•********•****•*•***•*******/ 

int 
Arm(root)  /*    root    is    a   ptr    to    tree/subtree      */ 

NodeRec         **root;  /*    currently   working   with  */ 

/*  <ARM>    ::=         <EXPRESSION>then<EXPRESSION>  */ 

{ 

int         flag; 

NodeRec  *temp  =  NULL;  /*  temp  ptr  to  a  node  in  tree      */ 

if ((flag  =  Expression (Stemp) )  !=  TRUE)  /*  if  an  error  try  to  recover  by   */ 

EatEm(KW_+THEN_) ;  /*  look  for  THEN, ELSE, ELSIF, ENDIF  */ 

if  (ByPass (KW_  +  THEN_) ) 
{   *root  =  CreateNode (KW_  +  THEN_) ; 
(•root)  ->  lptr  =  temp; 
if  (Expression (Stemp)  ==  TRUE) 

(•root)  ->  rptr  =  temp; 
else  /*  report  it  and  try  to  press  on   */ 

ErrorHandler ( line_no, ERR_m, 
(long) THEN_) ; 
}  /*  end  begin  if  THEN  */ 

else  /*  report  it  and  try  to  press  on   */ 

ErrorHandler (line_no, ERR_f , 

(long)KW_+THEN_) ; 
return (flag) ; 
}  /*  end  Arm()  */ 

/•a********************************************************************/ 


/*    root    is    a    ptr    to    tree/subtree  */ 

/*    currently   working   with  */ 

::=        begin    <BLOCKBODY>   end  */ 

if  (Bypass (KW_  +  BEGIN_) ) 

{   *root  =  CreateNode (KW_  +  BEGIN_) ;           /*  sets  root  for  return  errors  */ 

/*  have  already  been  reported  */ 

if  (BlockBody (S ( (*root) ->lptr) ) !=  TRUE)       /*  look  for  BLOCKBODY  */ 


int 

Block (root) 

NodeRec 

"root; 

/* 

{ 

<BLOCK> 
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Error Handler (line_no, ERR_m, 
(long) BEGIN_) ; 
if (ByPass (KW_  +  END_) ) 
{   (*root)  ->rptr  =  CreateNode (KW_  +  END_ 

return (TRUE) ; 
} 
ErrorHandler (line_no,  ERR_f , 

(long) KW_+END_) ; 
return (ERROR_) ; 

;e     return (FALSE) ; 


/*  note  it,  try  &  fix 


/*  end  bypass  END 
/*  note  it,  no  fix 


/*  end  ByPass  BEGIN 


/*  end  BLOCK 


/it*********************************************************************/ 


int 
Compound (root ) 

NodeRec         **root; 


/*    root    is    a   ptr    to   tree/subtree      */ 
/*    currently   working   with  */ 


/*    <COMPOUND> 


' ( ' <ELEMENTS> ' ) ' | ' { ' <ELEMENTS> ' } ' I '< ' <ELEMENTS> ' > 
where    <ELEMENTS>   may   be   empty      */ 


if (ByPass (LTPARENJ ) 
{       Elements (root ) ; 

if  (! ByPass (RTPAREN_)  ) 

ErrorHandler (line_no, ERR_f , 
(long)RTPAREN_) ; 


/*  only  look  for  elemt ' s  because  */ 
/*  errors  reported  via  QualExp  */ 
/*  note  it,  no  fix  */ 


if (* root  ==  NULL) 

•root  =  CreateNode (EMPTYCOMPOUND) 
else  if ( (*root) ->name  ==  COMMA_) 

(♦root) ->name  =  ELLIST; 
return (TRUE) ; 


• 


/*  now  check  for  empty  compounds/  */ 
/*  compounds  w/  multiple  elements  */ 


/*  end  if  LTPAREN) 


if (ByPass (LTSQUIGJ ) 
(   Elements  (root )  ; 

if  ( !ByPass (RTSQUIGJ ) 

ErrorHandler (line_no, ERR_f , 
(long)RTSQUIG  ) 


/*  only  look  for  'em, 

/*  errors  reported  via  QualExp 

/*  note  it,  no  fix 


if  (Toot  ==  NULL) 

♦root  =  CreateNode (EMPTYCOMPOUND) 
else  if  (  ("root) ->name  ==  COMMA_) 

(•root) ->name  =  ELLIST; 
return (TRUE) ; 


\ 


/*  check  for  empty  compounds  and   */ 
/*  compounds  w/  multiple  elements  */ 


/*  end  if  LTSQUIG) 


if (3yPass (ST_SEQUENCE_) ) 
i   Elements (root ) ; 

if  (  ! ByPass (END_SEQUENCE_)  ) 

ErrorHandler (line_no, ERR_f , 

(long) END  SEQUENCE  ) 


/*  only  look  for  'em,  */ 

/*  errors  reported  via  QualExp    */ 

/*  note  it  &    no  fix  *7 


if  (Toot  —  NULL) 

*root  =  CreateNode (EMPTYSEQUENCE) ; 

else    MakeNewRoot (root , SEQUENCE, RIGHT) 

return (TRUE) ; 
} 
return (FALSE) ; 


/*  now  check  for  empty  sequences/  */ 
/*  sequences  w/  multiple  elements  */ 


/*  end  ByPass  ST_SEQUENCE_ 
/*  none  of  the  above 
/*  end  CompoundO 


/************************************yf*********************************/ 
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int 
Elements (root) 

NodeRec    **root; 


/*  root  is  a  ptr  to  tree/subtree 


/* 

( 

int 


/*    currently   working   with 
<ELEMENTS>     ::=    <QUALEXP>     ( , <QUALEXP>) * 


flag; 


if ((flag  =  QualExp(root) )  ==  ERROR_) 

EatEm(COMMA_) ; 
while (ByPass (COMMA_) ) 

(   MakeNewRoot (root, COMMA_, LEFT) ; 

if  (Elements (& ( ('root) ->rptr) )  !=  TRUE) 
ErrorHandler (line_no, ERR_p, 
(long)COMMA_) ; 
if  (  (*root) ->rptr->name  !=  COMMA_) 
MakeNewRoot (s ( ( *root) ->rptr) , 
COMMA_, LEFT) ; 
} 

return ( flag) ; 


/*  errors  already  reported 

/*  recursively  look  for  next 

/*  qualexp 

/*  found  a  COMMA  so  fix  tree 


/*  note  it,  try  &  fix 

/*  fix  tree  so  all  QualExp's 

/*  hang  to  the  LEFT 

/*  end  while  ByPass (COMMA_) 

/*  end  Elements ( ) 


********************************************************************** 


int 
Denotation (root) 

NodeRec         **root; 


/*    root    is    a   ptr    to    tree/subtree      */ 
/*    currently   working   with  */ 


/*       <DENOTATION>     ::=         <LITERAL>     |     <CONSTANT>     |     <FORMALS> I ->    <ACTUAL>  * 

*  where    LITERAL    is    quoted (' )     string   of    zero    or   more    chars    and  * 

*  where   CONSTANT    is    an    integer    or   decimal    number  * 

*  NOTE:      <FORMALS>    | ->   <ACTUAL>        was    already   checked  by  Actual ()  */ 
( 

long        ptr; 

if (ptr    =    ByPass (LITERAL_) ) 

{    *root    =   CreateNode(LITERAL_) ; 

(*root)     ->index    =   ptr; 

return (TRUE) ; 


} 

if     (ByPass (EMPT_LIT_) ) 

{       *root    =   CreateNode(LITERAL_) ; 

(♦root)     ->index   =   NULL; 

return (TRUE) ; 
} 

if (ptr    =ByPass (CONSTANTJ ) 
(       "root    =   CreateNode(CONSTANT_) ; 

(*root)     ->index   =   ptr; 

return (TRUE) ; 
} 

return (FALSE) ; 


/*    end    a    LITERAL 


/*    end   a    LITERAL 


/*    end    a   CONSTANT 

/*   default,    none    of    the    above 

/*    end   Denotation () 
********************************************************************** 


int 
ArgBinding (root) 

NodeRec    **root; 


/*  root  is  a  ptr  to  tree/subtree   */ 
/*  currently  working  with         »/ 
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<ARGBINDING> 


,_     i  r  i 


['      (<OPXQUALEXP>     |     <QUALEXPXOP>     I     <0P>)      ']' 


{ 

int  specialcase; 

NodeRec  'temp  =  NULL; 

extern  int    argbind; 

if (ByPass (LTBRAKET_) ) 
{   argbind  =  TRUE; 


/*  temp  ptr  to  node  in  tree  »/ 

/*  global  flag  needed  to  make  */ 

/*  PHI  deterministic  */ 

/*  set  global  flag,  needed  to  */ 

/*  PHI  deterministic.  */ 


specialcase  =  ( IBall (ADD_, 1)  II  IBall (SUB_, 1 )) ; 

tfifdef    DE3UG 

print f ( "special  case  =  %d  argbind  =  %d\n", specialcase, argbind) ; 

#endif 


if  (Op(root) ) 
{   if  (ByPass (RTBRAKET_) ) 
{   argbind  =  FALSE; 

MakeNewRoot ( root , ARGBINDOP, LEFT) ; 
return (TRUE) ; 
1 

MakeNewRoot ( root , ARGLEADOP, LEFT) ; 
if (IBall (ADD_, 1)  II  IBall (SUB_, 1 ) ) 
specialcase  =  FALSE; 

if  (  (QualExpU  (*root)  ->rptr)  )  ==TRUE) 
( 

if (ByPass (RTBRAKET_) ) 

f   argbind  =  FALSE;    return (TRUE) ;  ) 

else 

if  (specialcase  &&  Op(Stemp) 

SS  ByPass (RTBRAKET_) ) 
(   ( (*root) ->lptr) ->rptr= (*root) ->rpt 

(•root)  ->rptr  =  temp; 

( (  (*root) ->lptr) ->name  ==  ADD_)  ? 

(  ( (*root) ->lptr) ->name=POS_)  : 

(  (  (*root) ->lptr)  ->name  =  NEG_)  ; 

(*root)->  name  =  ARGTRAILOP; 

argbind  =  FALSE; 

return (TRUE) ; 
} 


) 

argbind  =  FALSE; 

ErrorHandler (line_no, ERR_q, NULL) ; 

return (ERROR_) ; 

( (QualExp(root) )  !=  FALSE) 
MakeNewRoot (root , ARGTRAILOP,  LEFT) 
argbind  =  FALSE; 
if (Op(& ('root) ->rptr) 

&&  ByPass (RTBRAKET_) ) 

return (TRUE) ; 
ErrorHandler (line_no, ERR_q,NULL) ; 
return (ERROR  ) ; 


/*  begin  Op  comes  first 

/*  looking  for  [Op] 

/*  reset  global  flag 

/*  had  (  <0p>  ] 

/*  end  if  ByPass  RTBRAKET_ 

/*  don't  have  just  an  Op 

/*  might  be  +/-   +/-  QualExp 

/*  and  don't  want  to  accept 

/*  +/-   +/-  QualExp  Op  later  on 

/*  two  cases  where  QualExp  could 

/*  be  TRUE   <Op><QualExp> 

/*  or  +  I -<QualExp><Op> 

/*  reset  global  flag 

/*  could  be  +/-  PRIMARY 


r  ; 


) 

return (FALSE) ; 


it*************************************** 


/*  now  fix  the  tree 


/*  <0p>  came  last  as  a  "," 

/*  reset  giobalflag 

/*  end  else  specialcase  a    Op ( ) 

/*  S&  RTBRAKET_ 

/*  end  2  cases  where  QualExp  TRUE 

/*  reset  giobalflag 

/*  report  it,  no  fix 

/*  end  Op  comes  first 

/*  found  something 

/*  reset  global  flag  & 

/*  see  if  can  continue 

/*  report  it,  no  fix 

/*  end  if  QualExp  comes  first 

/*  end  if  ByPass  LTBRAKET 

/*  default,  none  of  the  above 

/*  end  ArgBindingO 
it****************************- 


int 
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Op(root)  /*    root    is    a   ptr    to    tree/subtree      */ 

NodeRec         "root;  /*    currently   working   with  */ 

/*  <OP>     ::=    ,      I      !      I     <RELATOR>     |     <ADDOP>     I     <MULOP>  */ 

{ 

int        flag; 

if (flag  =  ByPass (COMMA_)  ) 

"root  =  CreateNode (COMMA_) ; 

else  if (flag  =  ByPass (SUBSCRIPT^) ) 
'root  =  CreateNode (SUBSCRIPTJ ; 

else  if (flag  =  Relator ()) 

'root  =  CreateNode ( flag) ; 

else  if (flag  =  AddOp ( ) ) 

*root  =  CreateNode ( flag) ; 

else  if  (flag  =  MulOpO) 

•root  =  CreateNode (flag) ; 

return ( flag) ; 
}  /*  end  Op  */ 

/•A********************************************************************/ 

int 
TypeExp ( root )  /*  root  is  a  ptr  to  tree/subtree   */ 

NodeRec    "root;  /*  currently  working  with         */ 

/*  <TYPEEXP>  ::=     <TYPEDOM>  (  ->  <TYPEEXP>    )*  */ 

{ 

NodeRec  *newroot;  /*  temp  ptr  to  nodes  in  the  tree   */ 

int  flag; 

if ((flag    =    TypeDom(root) )     ==    TRUE) 

if    (ByPass (RTARROW_) )  /*    will    recursively    search    for  */ 

{       newroot    =  CreateNode (RTARROW_) ;  /*   more   TYPEEXP's  */ 

newroot    ->lptr   =    'root;  /*    fix    root    for    return  */ 

'root    =    newroot; 

if (TypeExp (&( ('root) ->rptr) )     !=    TRUE) 
{         ErrorHandler (line_no, ERR9, (long) RTARROW_) ; 

return (ERROR_) ; 
} 
}  /*    end    recursive    search  */ 

return (flag) ; 
}  /*    end   TypeExp  */ 

/••a*******************************************************************/ 

int 
TypeDom (root )  /*    root    is    a   ptr    to    tree/subtree      */ 

NodeRec        "root;  /*    currently   working   with  */ 

/*  <TYPEDOM>     ::=         <TYPETERM>(+    <TYPEDOM>) *  */ 

{ 

NodeRec   'newroot;  /*  temp  ptr  to  nodes  in  the  tree   */ 

int       flag; 

if ((flag  =  TypeTerm(root) )  ==  TRUE) 

if  (ByPass (ADD_) )  /*  will  recursively  search  for  */ 

{   newroot  =  CreateNode (TYPEPLUS) ;  /*  more  TYPEDOM' s  */ 

newroot  ->lptr  =  'root;  /*  fix  root  for  return  */ 
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*root  =  newroot; 

if  (TypeDomU  (  (*root) ->rptr)  )  !=  TRUE) 

{   ErrorHandler (line  no, ERR9, (long)ADDJ  ; 

return (ERROR_) ; 
I 
}  /*  end  recursive  search  */ 

return (flag) ; 
)  /*  end  TypeDomO  */ 

/••it*******************************************************************/ 


mt 
TypeTerm (root) 

NodeRec    **root; 


/*  root  is  a  ptr  to  tree/subtree   */ 
/*  currently  working  with         */ 


/' 


<TYPETERM> 


NodeRec      *newroot; 

int  flag; 


<TYPEFAC>('*'     <TYPETERM>) *  */ 

/*    temp   ptr    to    nodes    in    the   tree      */ 


if ((flag  =  TypeFac(root) )  ==  TRUE) 
if  (ByPass (MULT_) ) 

{   newroot  =  CreateNode (TYPETIMES) ; 
newroot  ->lptr  =  *root; 
*root  =  newroot; 

if (TypeTerm(& ( (*root) ->rptr) )  !=  TRUE) 
{    ErrorHandler (lineno, ERR9, 
(long)MULT_) ; 
return (ERROR  ) ; 


/*  will  recursively  search  for     */ 
/*  more  TiPETERMS's  */ 

/*  fix  root  for  return  */ 


) 
return ( flag) ; 


/*  end  recursive  search 


/*  end  TypeTerm () 


/*****•*•******************•***•******•******•*****•*•********•***■****•/ 


mt 
TypeFac  (root) 

NodeRec    **root; 


/*  root  is  a  ptr  to  tree/subtree   */ 
/*  currently  working  with         */ 


/* 
/* 

/* 
/* 

( 

NodeRec 
int 
long 


<TYPEFAC>  : :=    <TYPEPRIMARY>@  |  <TYPEPRIMARY>  | 
<ID>  '«'  <TYPEEXP>  (,<TYPEEXP>)  *  '»'  <ACTUAL> 

Where  «TYPEEXP  ( ,  TYPEEXP,  .  .  .  )  »  and/or  <ACTUAL> 

need  not  be  present 


•newroot ; 

flag; 

ptr; 


/*  temp  ptr  to  nodes  in  the  tree 


*/ 
*/ 

*/ 
*/ 


if (ptr  =  ByPass ( IDENTIFIER^ ) 
(   *root  =  CreateNode ( IDENTIFIERJ ; 
(•root)  ->index  =  ptr; 


} 


if (ByPass (ST_SEQUENCE_)  4S  ByPass (ST_SEQUENCE_) ) 
{   ErrorHandler (lineno, ERR_r,  NULL)  ; 

return (ERROR_) ; 
)  /*  end  bypass  << 

goto  CHECK; 

/*  end  if  ID 


if ((flag  =  TypePrimary (root) )  ==  TRUE) 

goto  CHECK; 
return ( flag) ; 


/*  return  either  ERROR  or  FALSE 
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CHECK:  if (ByPass (STARJ ) 

{  newroot  =  CreateNode (STAR_ 

newroot  ->lptr  =  (*root); 

♦root  =  newroot; 
} 


/*  end  if  STAR 


'/ 


return (TRUE) ;  /*  made  it  this  far,  ail  OK       */ 

}  /*  end  TypeFacO  */ 

/••••••••••a***********************************************************/ 


int 
TypePrimary (root) 

NodeRec    "root; 


/*  root  is  a  ptr  to  tree/subtree 

/*  currently  working  with 


/* 

/* 
{ 


<TYPEPRIMARY>     ::=    <PRIMTYPE>     |      '('     <TYPEEXP>     ')' 
NOTE:       ID    already   checked    in    TYPEFACO 


if (ByPass (LTPARENJ ) 

{       if  (TypeExp(root)     !=    TRUE) 

ErrorHandler (linejio,  ERR9, 
(long) LTPAREN_) 


/*  note  it,  no  f: 


*/ 
*/ 

*/ 
*/ 


if (ByPass (RTPARENJ ) 

return (TRUE) ; 
else 

(   ErrorHandler (line_no, ERR_f, 
(long)RTPAREN_) 

return (ERROR_) ; 
) 


} 


if (PrimType (root) ) 

return (TRUE) ; 


/*  end  ByPass  ' ( 


return (FALSE) ; 


/*  default 

/*  end  TypePrimary ( ) 


/••a**************************************************************** 


int 
PrimType (root) 

NodeRec         **root; 


/*    root    is    a   ptr    to   tree/subtree      */ 
/*    currently   working   with  */ 


/*    <PRIMTYPE>    : :=    real    I    integer    |    natural    I    boolean    |    trivial     I    type    */ 


if (ByPass (REAL_) ) 

{   *root  =  CreateNode (REALJ ; 

return (TRUE) ; 
} 


/*  end  if  REAL 


if (ByPass (INTEGERJ ) 

{   "root  =  CreateNode (INTEGERJ ; 

return (TRUE) ; 
} 

if (ByPass (NATURALJ ) 

{   Toot  =  CreateNode (NATURALJ ; 

return (TRUE) ; 
} 


/*  end  if  INTEGER 


/*  end  if  NATURAL 


if (ByPass (BOOLEANJ ) 

{   *root  =  CreateNode (BOOLEANJ ; 
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return (TRUE) ; 
)  /*  end  if  BOOLEAN  */ 

if  (ByPass (TRIVIALJ  ) 

{   *root  =  CreateNode (TRIVIALJ ; 

return (TRUE) ; 
}  /*  end  if  TRIVIAL  */ 

if (ByPass (KW_  +  TYPE_) ) 

(   'root  =  CreateNode (KW_  +  TYPE_) ; 

return (TRUE) ; 
}  /*  end  if  TYPE  */ 

return (FALSE) ;  /*  default  -  none  of  the  above     */ 

/*  end  PrimTypeO  */ 

•  it********************************************************************/ 
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/********** 
* 

*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 
*********** 

*  This  file 
* 

* 
* 
* 
*********** 

*  Modified 
* 

* 
* 
* 
* 


************************************************************* 


Parser  Ut 
parsr_uti 
Ma  j  E.J. 
01/26/87 
03/03/87 
04/23/87 
************** 

contains  the 
CreateNode ( ) 
FillBuff  () 
NodeName ( ) 


PUBLIC  DOMAIN  SOFTWARE 
ilities 
l.c 

COLE  /  Capt  J.E.  CONNELL 


FillBufferO  now  calls  GetTokenO  direct.     * 
*********************************************** 

utility  modules  for  the  parser:  * 

MakeNewRoot  ()       ByPassO  * 

IsFormaK)  IBallO  * 

EnterNameO         FindNameO  * 


************************************************************* 

:   03/20/87  -  Buffer  Handling  routines  added  -  JC  * 

04/23/87  -  FillBuferO  calls  GetTokenO  direct  vice  * 

working  with  intermediate  file  of  tokens .  * 

EnterNameO  and  FindNameO  added  to  place  * 

IDs,  LITERALS,  and  CONSTANTS  into  the  name  * 

table.     JC  * 


*********************************************************************** 


tinclude  <stdio.h> 
#include  <parser.h> 

extern    int    line_no; 

extern    FILE   *pinfile; 


/*  global  var,  holds  line  no 

/*  of  source  prog 

/*  global  working  file 


char      token [MAXLINE] ="x"; 
NameRec    *nametable [TABLESIZE+  1] 
*EnterName () ; 


/*  Init  token [0]  to  value  other    */ 

/*  than  NULL.   Token [0]  holds  the  */ 

/*  length  of  the  string.  */ 

/*  add  1  because  [0]  is  unusable   */ 


/**********************************************************************/ 
/*  UTILITIES  */ 


NodeRec    * 
CreateNode (op) 
NodeType    op; 


/*    operator    type    of    node 


/*  Creates  a  tree  node  and  returns  the  pointer  (temp)  to  this  node.  */ 
/*  Accepts  node  type  (op),  an  integer,  and  inserts  it  into  the  node.  */ 
( 

NodeRec         *temp; 


/*    create   a    node 


temp    =   C ALLOC (1, NodeRec) ; 

temp    ->    name   =    op; 

temp    ->    In    =   line_no; 

temp    ->    lptr    =    (temp    ->    rptr)     =    NULL; 

return (temp) ; 
}  /*        end  CreateNode ()  */ 

/••••••A***************************************************************/ 


void 
MakeNewRoot ( root , type,  side) 
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NodeRec      "root;                                                                            /*  old   root    of    subtree    -                         */ 

/*  will    turn    into    new   root                    */ 

int                type,    side;                                                                   /*  (type)    is    type   of    new    root             */ 

/*  (side)    is    side   to   att    old    root    */ 

/*    Creates    a    new   working    root    for   subtree.  */ 

/*    Old   root    is    attached   to    lt/rt    based   on   value    of    (side)  */ 

{ 

NodeRec        *newroot; 

newroot  =  CreateNode (type) ; 

(side  ==  LEFT)  ? 

(newroot    ->lptr    =    *root)     :     (newroot    ->rptr    =    "root); 

"root    =    newroot; 
}  /*    end   MakeNewRoot  */ 

/it*********************************************************************/ 

void 
FillBuf f (start) 

long      *start;                                                                                      /*   which    slot    in    the   buffer  */ 

/*    array   to    start    the    filling  «/ 

/*    Requires    the   buffer    array   and  buffer   ptr   to   be   previously   defined.  */ 

/*    Fills    the   buffer    with   tokens    by   calling   GetTokenO.       Buffer    filled  */ 

/*    until    1)    end   of    user   prog    reached  or    2)    end   of    the    array    reached  */ 

/*    If    the    token    is    a    literal,     id,    or   constant    then   EnterName ( )     is  */ 

/*    called  to   enter    it    into    the    nametable.  */ 

/*    Lastly,    resets    the   buffer   ptr   to    tokenbuf f [0 ] .  */ 

( 

extern  long   tokenbuff[],  *ptr; 

int  token_num;  /*  identifies  a  token  type        */ 

N'ameRec  *nptr;  /*  ptr  to  structure  of  NameRec     */ 

ptr  =  start;  /*  intit  ptr  to  travel  thru  buff   */ 

do 

{   token_num  =  GetToken  (token) ; 
*ptr  =  token_num; 

++ptr ; 

switch  (token_num) 
(   case  LITERAL_ 
case  CONSTANT_ 
case  IDENTIFIER_ 

{   token[0]  =  strlen (token) ;  /*  insert  length  of  sting         */ 

if ( (nptr=EnterName (token) ) ) 
{   *ptr  =  (long)nptr;  /*  address  of  token  */ 

++ptr; 
} 

else  Error-Handler  (NULL,  ERR7, NULL)  ;     /*  HANDLE  MEMORY  OVERFLOW!         */ 

break; 

}  /*  end  case  */ 

default:  /*  do  nothing  */ 

)  /*  end  switch  */ 

)  while ( (token_num  !=  EOF)   && 

(ptr  <  Stokenbuff [BUFSIZE] )) ; 

ptr  =  Stokenbuff  [Oj ;  /*  reset  the  buffer  ptr  */ 

)  /*  end  FillBuffO  »/ 

/a*********************************************************************/ 
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long 
ByPass (tgt) 
int    tgt; 

/*  Checks  to  see  if  the  next  token  in  the  buffer  matches  the  target.  */ 
/*  If  so,  then  returns  the  token  no.  and  increments  the  buffer  */ 
/*  pointer  */ 

( 

extern    long    tokenbuff[],  *ptr; 

if(ptr  >=  Stokenbuf f [BUFSIZE] )  /*  see  if  at  end  of  buffer        */ 

FillBuff (itokenbuff [0]  )  ;  /*  refill  buffer  */ 

while (*ptr  ==  EOLN_) 

(   ++ptr;  /*  increment  counter  i  skip  */ 
++line_no; 

if(ptr  ==  Stokenbuf f [BUFSIZE] )  /*  see  if  at  end  of  buff  */ 

FillBuff (itokenbuff [0] ) ;  /*  refill  buffer  */ 

)  /*  end  while  */ 

if  (*ptr  !=  tgt) 
return (FALSE) ; 

++ptr;  /*  otherwise,  it  was  found        */ 

if (ptr  ==  Stokenbuf f [BUFSIZE] )  /*  if  at  end  of  buffer  */ 

FillBuff (itokenbuff [0]) ;  /*  refill  buffer  */ 

switch  (tgt) 

(       case    LITERAL_ 

case    IDENTIFIER 

case    CONSTANT_  :  /*    return   ptr    to    struct  */ 

return (* (ptr++) ) ;  /*    holding   the   token  */ 

default:  /*    just    return   true  */ 

return (tgt) ; 

}  /*    end    swithch  */ 

}  /*    end   ByPass ( )  */ 

/•a********************************************************************/ 

int 
IsFormal (root )  /*    root    is    ptr   to    subtree  */ 

NodeRec         *root;  /*    currently    working   with  * / 

/*    Required   to   make    the    language   deterministic.    Compound ( )     returned  */ 

/*    TRUE    and   " I ->"    was    subsquently    found.    Formal    is    a    proper    subset    of  */ 

/*    the    compounds    so   need   to    insure   no   errors    in   the    f ormals .  */ 

/*    Performs    a    preorder    search   of    the    subtree.    NOTE:    assumes    that    root  */ 

/*  initially  points  to  a  non-null  compound  list.  */ 
( 

#ifdef        DEBUG 

printf ( "isf ormal   entered, root->name    =    %d\n", root->name) ; 

if    (root    ==   NULL)    printf ("root    is    null\n"); 

#endif 

if  (root  ==  NULL) 
return (TRUE) ; 

if (root->name==COMMA_  II  root->name==IDENTIFIER_ 

I  I  root->name==ELLIST) 
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if ( ( Is Formal (root->iptr) ) 

ii  ( IsFormal (root->rptr ) ) ) 

return (TRUE) ; 

return (FALSE) ; 
}  /*  end  Isformal  */ 

/**************•***•*********************************************•*****/ 

ir.t 
I Ball (tgt,  index) 

int        tgt,    index; 

/*   Checks    to    see    if   the    (index) th   token    in   the   buffer  matches   the  */ 

/*    target.       If    it    does    returns    TRUE   else    FALSE.      Does    not    increment  */ 

/*    the   buffer   pointer.      Checks    for    full   buffer    implemented   in   this  */ 

/*   manner    to    allow   for    future    flexibility.      Could   have   used   simple  */ 

/*    heuristic    of:  */ 

/*  if(ptr    +    (3*index)     >    Stokenbuf f  [BUFSIZE] )  Ref ilBuf fer ;  */ 

/*      at    the   expense    of   generality  */ 

extern      long        tokenbuff[],    *ptr; 
long  *tptr; 

if(ptr    >=    Stokenbuff [BUFSIZE] )  /*    see    if    at    end   of   buff    if  */ 

FillBuf f (Stokenbuf f [0] ) ;  /*    so,    refill    buffer  */ 

/*    start    over    if    had   to    refill  */ 

DO_AGAIN:  /*    buffer    during    check    for    tgt  */ 

tptr    =   ptr;  /*    set    working  pointer  */ 

while (*tptr  ==  EOLN_) 

{   ++tptr;  /*  increment  tptr  &  skip  EOLNs  */ 

if  (tptr  ==  Stokenbuf f [BUFSIZE] )  /*  see  if  at  end  of  buff  */ 

goto  REFIL;  /*  nedd  to  refill  buffer  and  */ 

/*  then  start  over  */ 

}  /*  end  while  */ 

for (/index  >1;  --index)  /*  only  enter  for  loop  if  need  to  */ 

{   switch  (*tptr)  /*  look  more  than  one  char  ahead  */ 

(   case  IDENTIFIER_:  /*  double  skip  because  next  */ 

case  CONSTANT_:  /*  entry  is  addr  of  element  */ 

case  LITERAL_:    tptr  +=  2;  break; 

case  EOLN_: 

while (*tptr  ==  EOLN_) 

{   ++tptr;  /*  increment  counter  S  skip        */ 

if (ptr  ==  Stokenbuf f [BUFSIZE] ) 

goto  REFIL;  /*  refill  buffer  S  start  over     */ 

}  /*  end  while  */ 

default:  ++tptr; 

)  /*  end  switch  */ 

if (tptr  >=  Stokenbuf f [BUFSIZE] )  /*  check  if  will  overflow  buff     */ 

goto  REFIL; 
}  /*  end  for  */ 

if  (*tptr  !=  tgt)  return (FALSE) ; 
else    return (TRUE) ; 

REFIL:  /*  take  what's  left  in  buffer,  */ 

/*  put  at  beginning,  now  refil  */ 

/*  rest  of  buffer  */ 
for (tptr  =  Stokenbuf f [0] ; 

ptr  <  Stokenbuf  f  [BUFSIZE]  ;   pt  r  *■+  ,  tpt  r  +  +  ) 

*tptr  =  *ptr;  /*  refill  buffer  from  current  */ 

FillBuf f (tptr) ;  /*  posit  to  end  */ 
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goto    DO_AGAIN;                                                                                  /*    refilled   buffer,    so    start  */ 

/*    over  */ 

}                                                                                                                        /*    end    IBall ()  */ 
/****•*****•***************************************************•*****•*/ 

char    * 
NodeName (ptr) 

NodeRec         *ptr; 

/*   Accepts   a   ptr   to   a    structure   of   NodeRec.      Dereferences    this   node  */ 

/*    to   get    a   ptr    to    structure    of   NameRec    which   hold   the    string  */ 

/*    containing   the    name    of    the    value    in   NodeRec.    Returns    the    name    to  */ 

/*    calling    routine  */ 
{ 

NameRec        *temp;                                                                                    /*    temp   ptr   to   data    struct  */ 

/*    holding    name    of    "*ptr"  */ 

temp   =    (NameRec    *) (pt r->index) ; 

return (temp->name    +    1) ; 

}                                                                                                                              /*    end   NodeName ()  */ 
/*•***•**********•******************•*********•********•***************•/ 
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APPENDIX  I 
ROCK  COMPILER  —  ERROR  HANDLER 


/*********** 
* 

*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 
************ 

*  This  file 
* 

* 

*  Algorithm 
* 

* 
* 

* 
* 

*  NOTE 
* 

* 

************ 

*  Modified 


************************************************************ 

PUBLIC  DOMAIN  SOFTWARE  * 

Error  Handler  * 

errors . c  * 

Maj  E.J.  COLE  /  Capt  J.E.  CONNELL  * 

01/20/87  * 

04/07/87  * 


************************************************************ 
contains  the  execution  modules  for  error  recovery.  < 

ErrorHandler  ()  ,  EatEmO 

:   ErrorHandler ( )  is  called  by  other  modules  in  the 

compiler.   It  insures  the  error  count  is  updated  and 
the*  error  is  written  to  the  error  file.    If  required, 
ErrorHandler ( )  calls  EatEmO  to  gobble  tokens  to  get  to 
a  known  point  in   the  parse.    Used  during  error 
recovery.    After  MAXERRORS  number  of  errors  simply 
returns  to  calling  routine. 

:   'errorfile'  must  have  been  initially  created  before 
ErrorHandler ( )  is  first  called  -  don't  want  to  append 
to  last  times  errors! 

*********************************************************** 


*********************************************************************** 


^include  <stdio.h> 
#include  <scanner.h> 
#include  <errors.h> 
extern    FILE    *errorfile; 


int 


nil m  errors  =  0 ; 


/*  working  file 

/*  running  talley  of  #  eroi 

/*  found  -  global  var 

/*  array  of  error  messages 


logical  OR  is 
'N' , 'Z' , 'B',or 
=  >  ", 


•\\/ 
1'"/ 


•errors [ ]  =  { 

'  incomplete  '!->'", 

•  RESERVED  FOR  FUTURE  USE" 

"W  without  following  '/ 

"$'  without  following  'R' 

'invalid  numeric  constant 

'literal  without  ending    -  ", 

'unidentified  char  in  input  program  ==>  ", 

'MEMORY  OVERFLOW  DURING  COMPILATION", 

'error  in  statement  following  ==>  ", 

'error  in  type  definition  following  ==>  ", 

'unable  to  complete  definition  of  blockbody  after  keyword 

'missing  or  misplaced  ';'  after  definition", 

'valid  qualexp/exp  not  found  in  the  def/auxdef", 
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/* 

d  */ 

/* 

e  */ 

/* 

f  */ 

/* 

g  */ 

/* 

h  */ 

/* 

i  */ 

/* 

J  " 

/* 

k  */ 

/* 

1  */ 

/* 

m  */ 

/* 

n  */ 

/* 

o  */ 

/* 

p  */ 

/* 

q  */ 

/* 

r  */ 

/* 

s  */ 

/* 

t  */ 

/* 

u  */ 

/* 

v  */ 

/* 

w  */ 

/* 

x*/ 

/* 

y  V 

/* 

z  */ 

/* 

aa  */ 

/* 

bb  */ 

/* 

cc  */ 

/* 

dd  */ 

/* 

ee  */ 

/* 

ff  */ 

/* 

gg  */ 

/* 

hh  */ 

/* 

ii  */ 

/* 

jj  */ 

/* 

kk  */ 

/* 

11  */ 

/* 

mm  */ 

"valid  typeexp  not  found  in  the  def", 

"formals  list  missing  or  error  in  formals  list", 

"misplaced  or  missing  ", 

"at  least  one  identifier  must  follow  keyword  TYPE", 

"unable  to  complete  def/auxdef  following  keyword  AND", 

"missing  or  invalid  auxdef  after  keyword  WHERE", 

"missing  or  misplaced  closing  paren  in  formals  list", 

"error  in  processing  multiple  Actuals", 

"missing  literal  after  keyword  FILE", 

"missing  or  invalid  exp  following  KEYWORD  ", 

"IF  statement  w/o  ENDIF", 

"error  in  formals  preceding  |— >", 

"missing  or  invalid  QualExp  following  COMMA  operator", 

"error  in  ArgBinding  -  check  QualExp  or  closing  bracket", 

"OZONE  LEVEL  I  -  for  19.99  the  feature  can  be  implemented  in  1999' 


NUMERIC  VALUE  EXPECTED  ", 

NATURAL  EXPECTED  ", 

INTEGER  OR  NATURAL  EXPECTED  ", 

ERROR  IN  TUPLE  DEFINITION  ", 

UNDEFINED  VARIABLE  IN  AND  SCOPE  ", 

FUNCTION  WITHOUT  FUNCTION  DEFINITION  ", 

FORMALS  MISMATCHED  ", 

FUNCTION  CALLED  WITHOUT  FUNCTION  DEFINITION 

REAL  NUMBER  EXPECTED  ", 

INVALID  CONSTANT  EXPRESSION  ", 

BOOLEAN  VALUE  EXPECTED  ", 

BOOLEAN  OPERATOR  EXPECTED  ", 

OUT  OF  RUN-TIME  MEMORY  SPACE  ", 


/ 


******** 


**************************************************************/ 


void 
ErrorHandler (line_no,err_no, str_num) 

int    line_no,  err_no; 
long    str_num; 

/*    use  long  because  str_num  is  either  pointer  to  a  string  "long"     */ 
/*    or  an  actual  number  (int  or  long)  */ 

{ 

fifdef   DEBUG 

printf("eh  entered,  err#  =  %d,  str_num  =  %ld\n", err_no, str_num) ; 

#endif 


if  (++num_errors  >  MAXERRORS)     return; 
errorfiie  =  f open ("errors .phi", "a") ; 


/*  append  to  what's  there 


if  (err_no  ==  ERR7)  /*  no  more  memory  - 

{   fprintf (errorfiie, "%s\n", errors [err_no] )  ;     /*  get  out  and  start  over 
user  err  ( ) 
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execl ( "rock .exe", "rock .exe", NULL) ; 
}  /*  end  if  no  more  memory 

fprintf (errorf ile, "line  %3d  :  %s  ", 
line_no, errors [err_no] ) ; 

switch  (err_no)    { 
case  ERR4: 
case  ERR5:    fprintf (errorf ile, "%s\n", (char  *) str_num) ;    break; 

case  ERR6:    fprintf (error file, "%. ls\n",  (char  *)str_num);  break; 


case  ERR8: 


switch (str 


(   case  LEQ_ 

case  NEQ_ 

case  GEQ_ 

case  EQ_ 

case  ADD_ 

case  SUB_ 

case  MULT 

case  IDIV 

case  RDIV_ 

case  SUBSCRIPT 

case  ORLOG_ 

case  ANDLOG 

case  NEGLOG 

case  COLON_ 

case  CAT_ 

case  LINERTARROW_: 

case  (KW_+GREATER_) 

case  (KW_+IN_) 

case  (KW_+LESS_) 

case  (KW_+NOTIN_ 

default : 

fprintf (errorfile, 
} 

break; 


num) 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 
fprintf 


(error 
(error 
(error 
(error 
(error 
(error 
(error 
(error 
(error 
(error 
(error 
(error 
(error 
(error 
(error 
(error 
(error 
(error 
(error 
(error 


file, 
file, 
file, 
file, 
file, 
file, 
file, 
file, 
file, 
file, 
file, 
file, 
file, 
file, 
file, 
file, 
file, 
file, 
file, 
file. 


•<=\n' 

*<>\n' 
•>=\n' 

•=\n") 

•+\n") 

•-\n") 

■*\n' 

'%\n' 

•An' 

•!\n' 

'\\/\: 

■AWn' 

'~\n' 

■:\n") 

"\n"] 

' ! ->\n") ; 

•GREATER\n" 

*IN\n") ; 

■LESS\n") ; 

'NOTINXn") ; 


break 
break 
break 
break 
break 
break 
break 
break 
break 
break 
break 
break 
break 
break 
break 
break 
break 
break 
break 
break 


•UNDEFINED  error\n") ; 


/*  end  switch  case  ERR8 


:RR9:    switch (str_num) 

fprintf (errorf ile, "+\n") ;  break; 

fprintf (errorf ile, "*\n") ;  break; 

fprintf (errorfile, "->\n") ;  break; 

fprintf (errorf ile, " (\n") ;  break; 


case  ADD_ 
case  MULT_ 
case  RTARROW 
case  LTPAREN 
default: 

fprintf (errorfile, "UNDEFINED  error\n" 

break; 


/*  end  switch  case  ERR9 


:ase  ERR_f :  switch ( str_num) 

case  KW_+AND_: 

case  KW_+WHERE_: 

fprintf (errorfile, "==\n 
break; 

case  RTPAREN_: 

fprintf (errorfile, ") \n" 
str_num=NULL;  break; 

case  RTSQUIG_: 

fprintf (errorfile, " }\n" 
str_num=NULL;  break; 

case  END_SEQUENCE_: 

fprintf (errorfile, ">\n" 
str  num=NULL;  break; 


)  ; 


)  ; 


/*  don't  want  to  go  to  EatEm 


/*  don't  want  to  go  to  EatEm 


/*  don't  want  to  go  to  EatEm 
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case    KW_+END_: 

fprintf (errorfile, "KEYWORD    END\n") ; 

str_num    +=   KW_;    break;  /*    set    up    for    call   toEatEm  */ 

case    KW_+THEN_: 

fprintf (errorfile, "KEYWORD   THEN\n")  ; 

break; 

default : 

fprintf (errorfile, "UNDEFINED   error\n")  ; 
}  /*    end   switch   case   ERR_f  */ 

break; 

case    ERR_m:    switch ( str_num)  { 

case    IF_  : 

fprintf (errorfile, "IF\n") ;  break; 

case    ELSIF_    : 

fprintf (errorfile, "ELSIFXn") ;         break; 
case    ELSE_      : 

fprintf (errorfile, "ELSEXn") ;  break; 

case    THEN_      : 

fprintf  (errorfile, "THENXn") ;  break; 

case    BEGIN_    : 

fprintf (errorfile, "BEGINXn") ;         break; 
default : 

fprintf (errorfile, "UNDEFINED    errorXn") ; 
}  /*    end   switch    case    ERR_m  */ 

str_num    +=    KW_;  /*  set    str_num  up   to   be   passed         */ 

break;  /*  to    EatEmO  */ 

default:         fprintf (errorfile,  "  \n")  ; 

}  /*  end   switch  */ 

f close (errorfile) ; 

if    ( (err_no    >=    ERR_a)     4S 
(err_no   <    ERR_aa)     &S 
(str_num    !=    NULL) ) 
Eat Em ( (int ) str_num) ; 
}  /*    end   ErrorHandler  */ 

/***•*********••*••**********•**•*•*****•******•******•*•*****•*****•* 

void 
EatEm (tgt) 

int    tgt; 

/*    Increments   token   buffer   pointer   until   tgt    token    is    found.  */ 

/*    Use    in   error    recovery   to    reach   a    known   point    in    the   program.  */ 

{ 

extern    long   tokenbuf f [ ] ,  *ptr; 

extern    int     line_no; 

#ifdef    DEBUG 

print f ( "eatem  entered,  tgt  =  %d\n",tgt); 

#endif 

while  Cptr  !=  EOF_)    { 
switch  (tgt) 
(   case  E0LN_  : 

++ptr;    ++line_no;    break; 

case  SEMI_  : 

if ( (*ptr==SEMI  )  ||  (*ptr==KW  +LET  )) 
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return; 
-Dtr;    break; 


case  EQUIV 


{ 


case  EQUIV_ 
case  SEMI_ 
case  KW_+AND_ 
case  KW_+LET_ 
default : 
}     break; 


switch  (  (int) *ptr) 


return; 
++ptr; 


/*  end  switch  case  EQUIV 


case  KW_+WHERE_ 
{   case  KW_+WKERE_ 
case  KW_+AND_ 
case  KW_+LET_ 
case  SEMI_ 
default 
}     break; 


switch  ((int)*ptr) 


return; 
++ptr; 


/*  end  switch  case  WHERE 


*/ 


case  KW  +AND 


{ 


case  KW_+AND_ 

case  KW_+LET 

case  SEMI_ 

default 

}     break; 


switch  ((int)*ptr) 


return; 

++ptr; 


/*  end  switch  case  AND 


case  RTPAREN_ 

(   case  RTPAREN_ 

case  LTPAREN_ 

case  COMMA_ 

case  EQUIV_ 

case  LINERTARROW 

case  KW_+LET_ 

case  KW_+AND_ 

case  SEMI_ 

default 

}     break; 


switch  ((int)*ptr) 


return; 
++ptr; 


/*  end  switch  case  RTPAREN 


case  KW 

_+  IF_ 

case  KW 

_+  ELSIF_ 

case  KW 

_+  ELSE_ 

case  KW 

_+  THEN_ 

{   case 

KW_+  ELSIF 

case 

KW_+  ELSE_ 

case 

KW_+  ENDIF 

case 

KW  +  THEN 

++ptr ; 


break; 


switch ( (int) *ptr ) 


return; 


/*  end  switch  case  THEN, 


case  COMMA_ 

{   case  COMMA_ 
case  LTPAREN_ 
case  RTPAREN_ 
case  LTSQUIG_ 
case  RTSQUIG_ 
case  ST_SEQUENCE_ 
case  END_SEQUENCE_ 
case  SEMI_ 
case  KW_+LET_ 
case  KW_+WHERE_ 
case  KW_+  AND_ 
default 


switch  (  (int) *ptr) 


return; 
++ptr; 
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break; 


/*  end  switch  case  COMMA 


case  KW_+END_ 

case  KW_+BEGIN_ 

{   case  KW_+END_ 
case  KW_+LET_ 
case  KW_+WHERE_ 
case  KW_^AND_ 
case  COMMA_ 
case  RTPAREN_ 
case  RTSQUIG_ 
case  END_SEQUENCE_ 
case  SEMI_ 
default 

}    break; 


switch  (  (int) *ptr) 


return; 
++ptr; 


/*  end  switch  case  BEGIN/END 


default  : 
return; 


'  *  *  *  • 


******************************** 


/*    end   swithch  */ 

/*    end   while  */ 

/*    end   EatEmO  */ 

••a*******************************/ 
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APPENDIX  J 
ROCK  COMPILER  —  SEMANTIC  CHECKER 


/••A******************************************************************* 

*  PUBLIC  DOMAIN  SOFTWARE  * 

*  * 

Semantic  Checker  Module  0  * 

SemO.c  * 

Maj  E.J.  COLE  /  Capt  J.E.  CONNELL                        * 

02/01/87  * 

04/03/87  * 


*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 

*  This  file  contains  the  following  modules  for  the  PHI  parser:         * 

*  * 

*  Hnumconvert  Numconvert  * 

*  * 

*  Algorithm  :  * 

*  This  module  contains  procedures  for  type  conversion.   If  the     * 

*  rt  child  of  a  node  may  be  converted  to  the  It  type  but  the  con-      * 

*  verse  is  not  true,  "Hnumconvert"  is  called.   If  either  side  may  be   * 

*  converted,  "numberconvert"  is  called  * 
••••••••••A************************************************************ 

*  Modified   :  * 
•••••a****************************************************************/ 

/•it****************************    Externals    ****************************/ 
#include    <semcheck.h> 

extern  void  terror  (); 

/**********************  hnumconvert  *****************************/ 

PHITYPE 

hnumconvert  (ltype,  rtype,  ptr)  /*  Type  conversions  for  the  */ 

/*  right  side  of  the  tree  only  */ 

PHITYPE  ltype,  rtype;  /*  Left  and  Right  types  */ 

nodal  ptr;  /*  Ptr  to  the  root  working  with  */ 

{extern  void  c_ztor  ();  /*  Generates  code  to  convert  */ 

/*  integer/natural  to  real  *7 

if  ((ltype  ==  BOOLEAN)  S&  (rtype  ==  BOOLEAN)) 

return  (BOOLEAN);  /*  No  type  conversion  needed       */ 

switch  (ltype)   {  /*  Predicate  actions  on  type  of  It*/ 

case  (REAL)  :  switch  (rtype)  {  /*  side  of  node  */ 

case  (REAL)  :  return  (REAL);  /*  Matching  types;  no  conv  req     */ 

case  (INTEGER)  : 

case  (NATURAL)  :  /*  Generate  code  for  conversion    */ 

c_ztor  ( ) ; 

return  (REAL) ; 
default  : 
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terror  (ERR_aa,  ptr->ln) ; 
return  (REAL) ;     } 

case  (INTEGER)  :  switch  (rtype)  { 
case  (INTEGER)  : 

case  (NATURAL)  :  return  (rtype); 
default  : 

terror  (ERR_cc,  ptr->in) ; 

return  (INTEGER);  } 

case  (NATURAL)  : 

if  (rtype  ==  NATURAL) 

return  (rtype) ; 
else  { 

terror  (ERR_bb,  ptr->ln) ; 
return  (NATURAL) ; 
} 
default  :  terror  (ERR_aa,  ptr->ln) ; 
return  (NATURAL) ; 


/*  No  appropriate  match;  error     */ 
/*  Rtn  real  so  semantic  check  con:*/ 


/*  Matching  types,  no  cor.v  req    */ 

/*  Can't  convert  from  real  to  int  */ 
/*  so  sandbag  the  programmer      */ 


/*  Only  one  match  poss  w/o  error   */ 


} 

/************************    Numconvert    ****************************/ 

PHITYPE 
numconvert     (ptr) 


nodal    ptr; 
{PHITYPE    ltype,     rtype; 
extern    PHITYPE    semcheck    (); 
extern    void   c_ztor    (); 

ltype    =    semcheck    (ptr->lptr); 

if     (ptr->rptr->name    ==     ( KW_   +    ENDIF_) ) 

return     (ltype) ; 
rtype    =    semcheck     (ptr->rptr); 


/*    Do    number    conversions    for 
/*   both    left    and   right    side 

/*    Left    and    right    child   types 


/*    Get    left    type 

/*  Special  case  of  "if"  sequence 

/*  Get  right  type 


if  ((ltype  ==  BOOLEAN)  ii  (rtype  ==  BOOLEAN))   /*  No  conversion  necessary 
return  (BOOLEAN) ; 


switch  (ltype)  { 

case  (REAL)  :  switch  (rtype)  { 
case  (REAL)  :  return  (REAL) ; 
case  (INTEGER)  : 
case  (NATURAL)  : 

c_ztor  ( )  ; 

return  (REAL) ; 
default  : 

terror  (ERR_aa,  ptr->rptr->ln) ; 

return  (REAL) ; 
) 

case  (NATURAL)  :  switch  (rtype)  { 
case  (REAL)  : 

c_ztor  ( )  ; 

return  (REAL) ; 
case  (INTEGER)  : 

return  (INTEGER) ; 
case  (NATURAL)  : 

return  (NATURAL) ; 
default  : 

terror  (ERR_aa,  ptr->rptr->ln) ; 

return  (NATURAL) ; 


/*  Predicate  actions  on  It  type 

/*  Types  are  same;  no  action  req 

/*  Generate  code  for  int/nat 

/*  to  real  conversion 

/*  No  converison  possible 


/*  Convert  left  side 

/*  No  conversion  necessary 
/*  No  conversion  necessary 


113 


} 

case  (INTEGER)  :  switch  (rtype)  { 

case  (REAL)  :  /*  Convert  left  side 

c_ztor  ( ) ; 
return  (REAL) ; 
case  (INTEGER)  : 
case  (NATURAL)  : 

return  (INTEGER);  /*  No  conversion  necessary 

default  : 

terror  (ERR_aa,  ptr->rptr->ln) ; 
return  (NATURAL) ; 
} 
default  : 

terror  (ERR_aa,  pt r->lptr->in) ;  /*  Types  are  not  numeric 

return  (NATURAL)  ; 
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/********************************************************************** 

*  PUBLIC  DOMAIN  SOFTWARE  * 

*  * 


Semcheck  Module  1 

Semi . c 

Maj   E.J.  COLE  /  Capt  J.E.  CONNELL 

01/02/87 

01/10/87 


* 

*       Tletdef 
Twhere 
Tandcheck 


Trtarrow 

Tdataauxdef 

Tauxand 


Tkindef 
Tauxand 
Ttypetimes 


*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 
*********************************************************************** 

*  This  file  contains  the  following  modules  for  the  PHI  parser:         * 

* 

* 

* 

*  Tandcheck  Tauxand  Ttypetimes  * 

*  * 

*  Algorithm  :  * 

*  This  module  contains  scoping  procedures  (Twhere  and  Tauxand)   * 

*  definition  procedures  (trtarrow,  tkindef,  ttypetimes)  and  the  data   * 

*  definition  procedure.  * 

*  * 
*********************************************************************** 

*  Modified   :  * 
a*********************************************************************/ 

/******************************    Externals    ****************************/ 
finclude    <semcheck.h> 
♦include    <string.h> 


extern    int    typeptr; 
extern    tnode    types    []; 
extern    void   terror    (); 


/*  For  "strcpy" 

/*  Typetable  and  pointer 


fnode  *fhead  =  NULL; 

/*************************  Tletdef  ******************************/ 

void 
tletdef  (ptr) 

nodal  ptr; 
{ 


/*  checks  types  of  both  branches   «/ 


semcheck  (ptr->lptr); 
semcheck  (ptr->rptr); 


) 


/*•***************•*******  Trtarrow  *****************************/ 

PHITYPE 
trtarrow  (ptr) 
nodai  ptr; 
(PHITYPE  ltype,  rtype; 
extern  void  putform  (); 


/*  Returns  type 


ltype  =  semcheck  (ptr->lptr) ; 
rtype  =  semcheck  (ptr->rptr) ; 

if  ( ! (ptr->lptr->name  ==  TYPETIMES)  II 

(ptr->lptr->name  ==  TYPEPLUS) ) 
putform  (ltype); 

return  (rtype) ; 


/*  Check  left  side  type 
/*  Check  right  side  type 


/*  Only  if  leftnode  not  '*'  or 
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/a************************  Tkindef  ******************************/ 

void 
tkindef  (ptr)  /*  Adds  variable  name  to  defstac<  */ 

nodal  ptr; 
(extern  defptr  defhead; 
extern  void  putdef  ( )  ; 
PHITYPE  rtype; 

rtype  =  semcheck  (ptr->rptr) ; 

putdef  (rtype,  ptr->lptr) ;  /*  Put  definition  in  defstack     */ 

def head->fptr  =  fhead;  /*  Append  formal  types  to  entry    */ 

fhead  =  NULL;  /*  Kill  fhead  */ 

} 

/•it***********************  t where  it******************************/ 

PHITYPE 
twhere  (ptr)  /*  Semcheck  where  node  */ 

nodal  ptr; 
(PHITYPE  type; 

semchecker  (ptr->lptr) ;  /*  Check  leftside  */ 

type  =  semchecker  (ptr->rptr);  /*  Check  right  side  */ 

return  (type) ; 
} 

/************************  TDatauxdef  ****************************/ 

void 
tdatauxdef  (ptr)  /*  WORKS  FOR  ONE  FORMALS  ONLY      */ 

nodal  ptr; 
(extern  void  c_store_code  (),  c_jmp  (); 
extern  PHITYPE  getdtype  (); 
extern  defptr  finddef  (); 
extern  char  'name  (); 
defptr  d_ptr; 
char   'holder  =  malloc  (8),  /*  Temp  holder  for  function  name   */ 

*nme  =  malloc  (8)  ; 
PHITYPE  rtype,  /*  Type  of  left  and  right  nodes    */ 

type,  /*  Type  of  datadef  */ 

count  =  0; 

nme  =  strcpy  (nme,  name  ()); 
c_jmp  (nme) ; 

holder  =  strcpy  (holder,  named ) ;  /*  Calculate  function  name        */ 

c_start_proc  (holder);  /*  Gen  code  for  starting  proc     */ 

rtype  =  semcheck  (ptr->rpt r) ;  /*  Get  type  of  right  ptr  */ 

if  (ptr->lptr->name  ==  IDENTIFIER_)  (  /*  Open  can  of  worms  to  typecheck  */ 

/*  if  left  is  ident.  */ 

if ( ! (d_ptr=f inddef (ptr->lptr->index) ) )  {    /*  No  prev  decl  of  this  variable   */ 
ptr->lptr->type  =  rtype; 
putvar  (rtype,  ptr->lptr) ; 
} 
else  if  (d_ptr->fptr  ==  NULL)   (  /*  Prev  decl  of  var  is  data  def    */ 

ptr->lptr->type  =  getdtype  (d_ptr) ; 
type  =  hnumconvert  (ptr->lptr->type, 

rtype,  ptr) ;  /*  Convert  rt  type  if  feasible     */ 

putvar  (type,  ptr->lptr) ; 
} 
else  /*  Prev  decl  of  var  is  another  var*/ 

terror  (ERR_dd,  ptr->lpt r->ln ) ; 
) 
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while  ('(holder  +  count)  !=  NULL)  {  /*  Push  piano  through  the  door     */ 

/*  to  copy  strings  */ 

(ptr->lptr->label  [count!)  =  (* (holder  +  count)); 
++count;  } 

c  store  code  ("ret\n");  /*  Generate  code  to  end  procedure  */ 

c~store~code  (nme) ;  /*  CANNOT  USE  C_END_?ROC  ()  HERE;  */ 

/*  NO  SCOPE  CHANGE!  */ 
c  store  code  (":\n"); 


} 


/••it*************************  And  Check  ****************•*************/ 

void 
and_check  (mark,  ptr,  mark_and)  /*  Check  and_list  for  var  defs     */ 

varptr  mark;  /*  Scope  delimiter  */ 

and_ptr  *mark_and,  ptr; 
{extern  varptr  varhead; 
extern  int  buff_ptr; 
extern  char  *code_buf fer; 
int  buf f_holder ; 
varptr  v_ptr  =  varhead; 

if  (ptr  !=  NULL)  {  /*  Ptr  =  NULL  is  base  for  recurs  */ 

and_check  (mark,  ptr->link,  mark_and) ;      /*  of  and_check  */ 

do  {  /*  Loop  to  evaluate  all  proper  */ 

/*  varptr  entries  */ 

/*  Check  if  equal  names  in  */ 

/*  and_list  &  var_list  */ 

/*  Not  a  function  definition  */ 
if (v_ptr->nptr->index==ptr->ptr->index) { 

buff_holder  =  buff_ptr;  /*  Save  code  buffer  pointer  */ 

buff_ptr  =  ptr->buf f ptr ;  /*  Get  location  of  variable  code  */ 

c_call_proc  (v_ptr->nptr->label) ;    /*  Generate  code  */ 

buff_ptr  =  buf f_holder ;  /*  Restore  buffer  pointer  */ 

if  (*mark_and  ==  ptr)  /*  Traverse  list  */ 

*mark_and  =  ptr->link; 

del_and  (ptr) ; 
break;  ) 

if  (v_ptr  ==  mark)  break;  /*  End  of  var  list  reached        */ 

v_ptr  =  v_ptr->link; 
)  while  (TRUE) ;  /*  Exit  is  accomplished  using  a    */ 

/*  break  in  the  loop  */ 

) 
} 

/•it****************************  Tauxand  ******************************/ 

void 
tauxand  (ptr)  /*  Semantic  check  for  and  node     */ 

nodal  ptr; 
'extern  FLAG  and_flag; 
extern  and_ptr  and_head; 

int  save_and;  /*  Holder  for  and  flag  */ 

varptr  mark;  /*  Mark  top  entry  in  the  varlist   */ 

and_ptr  tptr,  mark_and  =  and_head;  /*  Mark  current  head  of  and_stack  */ 

save_and  =  and_flag;  /*  Save  current  and_flag  */ 

ar.d_fiag  =  TRUE;  /*  Set  and  flag  */ 
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semcheck  (ptr->lptr) ;  /*  Semantic  Check  */ 

mark  =  varhead; 
semcheck  (ptr->rptr) ; 

and  check  (mark,  and_head,  &mark_and) ;         /*  Check  all  new  fctn  4  data  defs  */ 

and_flag  =  save_and;  /*  Restore  and  flag  */ 

tptr  =  and_head; 

while    (tptr    !=   NULL)  /*    Traverse    list    until    end  */ 

tptr    =    tptr->link; 

if    (mark_and    !=   and_head)  /*    Undefine   variables    found  */ 

terror     (ERR_ee,    ptr->ln) ; 

/it*****************************    TTvpe Times    ****************•***********/ 

PHITYPE 
ttypetimes  (ptr)  /*  Semantic  check  '*'  when  used    */ 

/*  for  types  */ 

nodal  ptr; 
{extern  void  putform  ()  ; 
PHITYPE  type; 

putform  (semcheck  (ptr->lptr )  )  ;                /*  Attach  formal  type  to  »/ 

/*  formal  list  */ 

if  (type  =  semcheck  (ptr->rptr) )               /*  Look  for  right  type;  if  0,      */ 

/*  end  of  insertions  */ 

putform  (type) ; 

return  (NULL) ;  /*  Always  return  NULL;  */ 

/*  This  value  is  used  by  parent    */ 


118 


*  PUBLIC  DOMAIN  SOFTWARE  * 

*  * 

*  Name  :  Semcheck  Module  2  * 

*  File  :  Sem2.c  * 

*  Authors  :  Maj   E.J.  COLE  /  Capt  J.E.  CONNELL                       * 

*  Started  :  01/02/87  * 

*  Archived  :  04/10/87  * 

*  Modified   :  * 
••••••a**************************************************************** 

*  This  file  contains  the  following  modules  for  the  PHI  parser:         * 

*  * 

*  Matchfor  Tfunauxdef  Tfunid         * 

*  Tactualist  Tid  Act_Walk       * 

*  Telist  * 

*  * 

*  Algorithm  :  * 

*  This  module  contains  the  procedures  needed  to  define  and  call     * 

*  functions.  Tfunauxdef  will  set  up  the  run-time  structure  of  the  fun-* 

*  ction,  tfunid  will  check  the  semantics  of  the  function,  &  matchfor,  * 

*  called  by  tfunid,  checks  for  the  proper  type  &  number  of  formal  pa-  * 

*  rameters .  * 

*  Tactualist    coordinates    the   checking   of   a    function   call.       It    uses    * 

*  both   telist    and  act_walk.      Actwalk   determines   whether   the   number   &      * 

*  type    of    actuals    is    correct,    and   telist    checks    each   element    list    and    * 

*  returns    its    type.  * 

*  Tid  performs    semantic    checking    for   program   variables.  * 

*  * 

*  Modified      :  * 
**********************************************************************/ 

/a*************************    Externals    it*******************************/ 

#include    < semcheck . h> 

#include    <string.h>  /*    For    "strcpy"  */ 

extern  tnode  types  [ ]  ; 
extern  varptr  varhead; 
extern    void   terror    (),    c_store_code    (); 

/a***************************    Globals    ********************************/ 

int    actual_count    =    0;  /*    count    of    all    actuals  */ 

/•it**************************   Matchfor    *******************************/ 

FLAG 
matchfor  (nptr,  def)  /*  Match  formals  */ 

/*  Called  by  tfunid  ()  only       */ 
nodal  nptr;  /*  Ptr  to  rt  side  of  funid  node    */ 

defptr  def;  /*  Ptr  to  var  table  for  fur.c  name  */ 

{extern  long  curr_addr; 
extern  fnode  *getfptr  (); 

extern  FLAG  form;  /*  Flag  set  when  formals  */ 

/*  are  generated  */ 

fnode  *tptr  =  getfptr  (def)  ; 

form  =  TRUE; 
tptr  =  def->fptr; 
curr  addr  =0; 
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(nptr->name  ==  IDENTIFIER_) 
(nptr->type)  =  tptr->type; 
nptr->addr  =  curr_addr; 
putvar  (tptr->type,  nptr) ; 
nptr  =  nptr->rptr; 
tptr  =  tptr->link; 


/*  Only  one  formal 


else  { 


/*  Multiple  formals 


do  { 


nptr->lptr->type  =  tptr->type; 
nptr->lptr->addr  =  curr_addr; 
curr_addr  =  curr_addr  + 

types  [tptr->type] .bytes; 
putvar  (tptr->type,  nptr->lptr) ; 
nptr  =  nptr->rptr; 
tptr  =  tptr->link; 
while ( (nptr !=NULL) &S (tptr !=NULL) 


/*  Halt  when  end  reacned 
/*  by  either  ptr 


form  =  FALSE; 


if  (nptr  !=  NULL  I  I  tptr  !=  NULL) 
return  (FALSE) ; 


/*  One  ptr  isn't  at  end  of  run     */ 
/*  Error  handled  in  calling  fctn   */ 


else    return     (TRUE) ; 


/************•***•****    Tf unauxdef    *******************************/ 

void 
tfunauxdef    (ptr)  /*    Type   check    funauxdef  */ 

nodal    ptr; 
(extern    long    curr_addr; 

extern    void   c_end_proc    (),    c_jmp    (); 

extern    char    "name    (); 

extern    nodal    hnumconvert    {); 

char    *nme    =   malloc    (8); 

PHITYPE  ltype,  rtype; 

varptr  varl,  mark  =  varhead; 

long  pres_addr  =  curr_addr; 


nme  =  strcpy  (nme,  name  ()); 
c_ jmp  (nme) ; 


/*  Name  for  jump  around  function   */ 
/*  Gen  code  to  jump  around  fctn    */ 


ltype  =  semcheck  (ptr->lptr) ; 
rtype  =  semcheck  (ptr->rptr) ; 


while  (varhead->link  !=  mark)  { 
varl  =  varhead; 
varhead  =  varhead->link; 
varl->link  =  NULL; 
free  (varl) ;         ) 


/*  Eliminate  formals  from  Ink  1st  «/ 


ptr->rptr   = 

hnumconvert    (ltype,    rtype,    ptr->rptr) ; 

c  end  proc  (nme) ; 


Convert  if  needed 


curr_addr  =  pres_addr; 


/*  Reset  addresses 
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/•a***************************  T fun id  ********************************/ 

PHITYPE 
tfunid  (ptr)  /*  Semantic  Check  for  tfunid      */ 

nodal  ptr; 
{extern  defptr  finddef  (); 
extern  long  curr_addr; 
extern  char  'name  (); 

int  count  =  0;  /*  Generic  loop  varient  */ 

defptr  def; 
char  'holder  =  malloc  (8); 

if  ( !  (def  =  finddef  (ptr->lptr->index)  ) )  {      /*  Func  name  not  found  */ 

terror  (ERR_ff,  ptr->ln) ; 
return  (NOTFOUND) ;         } 

else  { 

ptr->lptr->type  =  def->type;  /*  Set  node  type  */ 

ptr->type  =  def->type; 

putvar  (ptr->lptr->type,  ptr->lptr,  FALSE)  ; 

if  (Imatchfor  (ptr->rptr,  def))  /*  Match  formals  */ 

terror  (ERR_gg,  ptr->ln) ; 

else  { 

holder  =  strcpy  (holder,  name  ()); 

while  ('(holder  +  count)  !=  0)  {  /*  Push  piano  ->  door  to  copy      */ 

/*  string  to  array  */ 

(ptr->lptr->label  [count]) 
(  *  (holder  +  count)  )  ; 

++count;  ) 

ptr->iptr->addr    =    0; 

c_start_proc    (ptr->lptr->label)  ;  /*    Gen    code    for   begin    function  */ 

) 
) 
return    (pt r->type) ; 
} 

/■it**************************    Tellist    *********************************/ 

void 
telist  (ptr)  /*  Semantic  Check  for  element  1st  */ 

nodal  ptr; 
{ 

if  (ptr->rptr  !=  NULL)  /*  Only  semcheck  if  there  is       */ 

/*  something  there  */ 

semcheck  (ptr->rptr) ; 

semcheck  (ptr->lptr) ; 

c_store_code    ("call    ppop\n");  /*    Generate    code  */ 

c_store_code  ("push  cx\n"); 
c_store_code  ("push  di\n"); 
++actual    count; 


} 

/••A*************************    Act    Walk    *******************************/ 

void 
act_walk  (ptr, fptr)  /*  Recursive  procedure  to         */ 

/*  sem  check  actual  list  */ 
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nodal  ptr; 
fnode  *fptr; 
{ 

if  (pt£->rptr  !=  NULL)  /*  Recurse  until  NULL  ptr  is  hit   */ 

act_waik  (ptr->rptr,  fptr->link) ; 

semcheck  (ptr->lptr) ; 

if  (ptr->iptr->name  !=  ELLIST)     ( 

++actual_count;  /*  Incr  count  only  if  left        */ 

/*  sibling  is  an  ID  */ 

c_store_code  ("call  ppop\n");  /  *  Generate  code  to  put  addresses  */ 

/*  on  the  stack  */ 

c_store_code  ("push  cx\n"); 
c_store_code  ("push  di\n"); 
} 
I 
/•it**************************  Tactuals  *******************************/ 

PHITYPE 
tactuals  (ptr)  /*  Evaluate  actualists  */ 

nodal  ptr; 
(extern  void  c_call_proc  (); 

extern  FLAG  and_flag; 

extern  varptr  findvar  ( )  ; 

extern  defptr  finddef  (); 

extern  char  'name  (); 

defptr  def  =  finddef  (ptr->lptr->index) ;  /*  Defstack  pointer  */ 

varptr  var  =  findvar  (ptr->lpt r->index) ;  /*  Varstack  pointer  */ 

int  count_hold  =  actual_count; 

char  *long_buff  =  malioc  (10);  /*  Buffer  for  long  to  string  conv  */ 

long  convert;  /*  Conversion  variable  */ 

fnode  *fptr; 

actual_count  =  0; 

if  (def)  {  /*  Definition  found  */ 

if  ((!var  &S  and_flag)  II  var)  /*  Legitimate  cases  */ 

( 

fptr  =  def->fptr;  /*  Get  a  ptr  to  the  formal  nodes   */ 

act_walk  (ptr->rptr,  fptr); 

convert  =  actual_count ; 

c_store_code  ("mov  bx,  ");  /*  Generate  code  to  put  #  of      */ 

/*  actuals  on  the  stack  */ 

stcl_d  (long_buff,  convert);         /*  Long  to  string  conversion      */ 

c_store_code  (long_buff); 

c_store_code  ("\n"); 

c_call_proc  ("i_mov") ; 

if  ( (and_flag)  &&  ( !var) )  (  /*  Cover  "and"  scoping  rules      */ 

add_and  (ptr->lptr) ; 
c_call_proc  (name  ());  /*  Holder  for  real  name  */ 

} 
else 

c_call_proc  ( var->nptr->label) ;      /*  Gen  code  to  call  function      */ 
actual_count  =  count_hold;  /*  Restore  actual  count  */ 

return  (def->type) ; 
} 
} 
terror  (ERR_hh,  ptr->ln)  ;  /*  Function  name  not  found        */ 

return  (NOTFOUND) ; 
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/a**************************  Tid 
PHITYPE 

tid  (ptr) 

nodal  ptr; 
(extern  void  c_i_form  (); 

extern  long  curr_addr; 

extern  char  *name  () 

extern  int  formal  () 

extern  FLAG  and_flag; 

extern  varptr  findvar  ( )  ; 

extern  defptr  finddef  (); 

char  *long_buff  =  malloc  (10); 

varptr  var  =  findvar  (ptr->index) ; 

defptr  def; 


******************************** 


/*  Typecheck  Id  node 


*/ 


/*  Buffer  for  long  to  string  conv  */ 
/*  Look  for  definition  of  var      */ 


if  Cvar) 


{ 


if  (def  =  finddef  (ptr->index) )  ( 
if  (and_flag)  ( 
add_and  (ptr) ; 
c_call_proc  (name  ()); 
return  (getdtype  (def) ) ; 
}  ) 

else  return  (NOTFOUND) ; 


/*  Rtn  type  if  var  found 
/*  in  def  table 


/*  Get  and  return  type  definition  */ 


else  if  (formal  (var))   ( 

stcl_d  (long_buff,  var->npt r->addr ) ; 
c_i_form  (long_buff); 
} 
else 

c  call  proc  ( var->npt r->label ) ; 


/*  Long  to  string  conversion 


/*  If  no  formal  list,  assume  var   */ 
/*  is  an  assignment  */ 

/*  Generate  code  to  call  procedure 


return  (getvtype  (var) ) ; 


/*  to  assign  value 

/*  Return  variable  type 
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/•••A****************************************************************** 

*  PUBLIC  DOMAIN  SOFTWARE  * 

*  * 

*  Name  :  Semcheck  Module  #3  * 

*  File  :  Sem3.c  * 

*  Authors  :  Maj  E.J.  COLE  /  Capt  J.E.  CONNELL                      * 

*  Started  :  01/02/87  * 

*  Archived  :  04/02/87  * 

*  Modified   :  * 
••••••••••••••A******************************************************** 

*  This  file  contains  the  following  modules  for  the  PHI  parser:         * 

*  Trdivide  Tidivide  Tarithop       * 

*  Tprimary  Tconvert  Tconstant      * 

*  Tand  Tor  Tnegation      * 

*  * 

*  Algorithm  :  * 

*  This   module    contains    the   procedures    necessary    for    implementing    * 

*  arithmetic    &    boolean    operators.       Tarithop   coordinates    the    semantic      * 

*  checking   of    arithmetic    ops    by   calling   the   proper    function   based  * 

*  on    the    operator   type.       Trdivide    &    Tidivide    handle    semantic    checking    * 

*  for    real    &    int    division,     respectively.      For    all    other    arithmetic  * 

*  ops,    the   numconvert    procedure    (semO)is    called  to   perform   seman-  * 

*  tic   checking,    then   code    is   generated.  * 

*  For  each  boolean   operator,    the   appropriate   child (ren)    is    checked* 

*  and   code    is    generated   for   the    operation.  * 

*  In   addition,    tconstant    checks    the   type   of   a   simple   constant   by      * 

*  calling   convert,    &    then    returns    either    the    constant    type    or   an   error* 

*  * 

*  ♦•it********************************************* 

*  Modified      :  * 

*  it****************************************************** 

/it***************************    Externals    ******************************/ 

♦include    <semcheck.h> 

♦include   <string.h>  /*    For    "strcmpi"  */ 

extern    void   terror    (); 

extern    void   c_store_code    ();  /*    Store   asm    language   output  */ 

/*    to    a   buffer  */ 

/••a-**********************    Trdivide    *****************************/ 

void 
trdivide    (ptr)  /*    Division    of    real    operands  */ 

nodal    ptr; 
(PHITYPE    ltype,    rtype; 
extern    FLAG   err_found; 
extern    void   c_ztor    0; 

ltype    =    semcheck    (ptr->lptr ) ;  /*   Check    left    side    for   type  */ 

switch    (ltype)     {  /*   Make   convs    or    locate   errors  */ 

case    (REAL)     :    break; 
case    (INTEGER)     : 
case    (NATURAL)     : 
c_ztor     ( ) ; 
break; 
default    :    terror    (ERR_aa,    ptr->lptr->ln) ;  /*    Lt    child  must    rtn    numeric   type    */ 

return;  /*    Error,    no    need   to   go   thru    acode*/ 

} 
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rtype  =  semcheck  (ptr->rptr) ;  /*  Check  right  side  for  type       * / 

switch  (rtype)  ( 

case    (REAL)     :    break; 
case  .  (INTEGER)     : 
case     (NATURAL)     : 
c_ztor     ( ) ; 
break; 
default    :    terror    (ERR_aa,    ptr->rptr->ln) ; 

return;  /*    Error,    no    need   to   go    thru    acode*/ 

} 

acode    (ptr,    REAL) ;  /*    Generate    code  */ 

} 

/*************************    Tldivide    ******************************/ 

PHITYPE 
tidivide  (ptr)  /*  Semcheck  for  integer  division   */ 

nodal  ptr; 
(PHITYPE  Itype,  rtype,  type  =  NATURAL; 

ltype  =  semcheck  (ptr->lptr) ;  /*  TypeCheck  both  sides  */ 

rtype  =  semcheck  (ptr->rptr)  ; 

switch  (ltype)  (  /*  Check  It  for  Int/Natural  Type   */ 

case  (INTEGER)  :  type  =  INTEGER; 
case  (NATURAL)  :break; 

default  :  terror  (ERR_cc,  ptr->lptr->ln) ;    /*  If  not  Int  or  Nat,  error       */ 
return  (INTEGER); 
} 

switch  (rtype)  (  /*  Check  rt  for  Int/  Natural  type  */ 

case  (INTEGER)  :  type  =  INTEGER; 
case  (NATURAL)  :  break; 

default  :  terror  (ERR_cc,  ptr->rptr->ln)  ;    /*  If  not  Int  or  Nat,  error       */ 
return  (INTEGER) ; 
> 

acode  (ptr,  type);  /*  Generate  code  */ 

return  (type) ; 
} 

/a************************  TArithoD  *****************************/ 

PHITYPE 
arithop  (ptr)  /*  Type  Check  Addition,  */ 

/*  Multiplication,  Sequence  Ops    »/ 
nodal  ptr; 
(extern  PHITYPE  numconvert  (); 
int  type; 

switch  (ptr->name)  ( 

case  (ADD_)  :  /*  Addition  falls  through         */ 

case  (SUB_)  :  /*  Subtraction  falls  through      */ 

case  (MULT_)  :    if (type  =  numconvert (ptr ) )  ( 

acode  (ptr,  type) ; 

return  (type) ; } 
else  < 

terror  (ERR_aa,  ptr->ln) ; 

return  (NATURAL) ; 

> 
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case  (RDIV_)  :  trdivide  (ptr) ; 

ptr->type  =  type; 

return  (REAL) ; 
case  (IDIV_)  :  tidivide  (ptr); 

ptr->type  =  type; 

return  (INTEGER); 

case  (COLON_)  :  break; 

case  (CAT_)  :   break; 
} 


/*  Dummies  for  new, 

/*  but  watch  our  smoke! ! ! 


/it************************  Tprirnarv  *****************************/ 

PHITYPE 


tprimary  (ptr) 

nodal  ptr; 

(PHITYPE  type; 


/*  Handle  unary  "+"  or  "-" 


type  =  semcheck  (ptr->rptr) ; 


if  (  (type  !=  INTEGER)  && 
(type  !=  REAL)  S& 
(type  !=  NATURAL) ) 
terror  (ERR_aa,  ptr->rptr->ln) ; 


/*  Check  type  of  right  node 
/*  Type  must  be  a  number 


) 


else  if  ( (ptr->name)  ==  NEG_)  { 

c_store_code  ("call  igetvalue\n")  ; 
c_store_code  ("neg  ax\n"); 
c_store_code  ("call  iputvalue\n") ; 
} 

return  (type) ; 


/*  Negate  operation 
/*  Spew  code 


/*  Note  that  no  action  is  req 
/*  for  unary  "+" 


/***********•*************    Convert  ******************************/ 

PHITYPE 

convert    (string)  /*   Convert    const    to    real,    boolean,*/ 

/*    or    integer    value  */ 

stg   string;  /*    String   to    convert  */ 

(FLAG   e    =    FALSE,  /*    True    if    "e"    or    "E"    read  */ 

period    =    FALSE;  /*    True    if    a    period   has    been    read  */ 

int    count    =    0;  /*    Garden    variety    loop    counter  */ 


if  ((strempi  (string,  "FALSE") 

Si  strempi  (string,  "TRUE")))  { 


/*  If  not  boolean 


while  (string  [count]  !=  0)  ( 

if  ( ! isdigit  (string  [count]))  ( 


/*  Loop  until  end  of  string       */ 
/*  If  character  is  not  a  digit     */ 


if  ((string  [count]  ==  'e')  I 
(string  [count]  ==  'E'))  ( 

if  (e)  return  (ERROR); 
else  ( 

e  =  TRUE; 


/*  "e"  or  "E"  found 

/*  Cannot  have  two  "e"s 


if  ((string  [count  +  1]  ==  '+')  II 

(string  [count  +  1]  ==  '-')) 

++count; 
>  } 


/*  "+"  or  "-"  character 


126 


else  if  (string  [count]  =='.'){         /*  Decimal  point  found  */ 

if  (period)  return  (ERROR) ;       /*  Cannot  have  two  periods         */ 
else  period  =  TRUE; 
} 

else  return  (ERROR) ;         ) 

++count;      ) 

if  (e  ! I  period)  return  (REAL) ;  /*  If  gauntlet  has  been  run,       */ 

/*  period  or  "e"  makes  real       */ 
if  (string  [0]  ==  '-')   return  (INTEGER);       /*  Negative  sign  makes  an  integer  */ 

return  (NATURAL) ;  }  /*  If  no  other  num  types,  natural  */ 

return  (BOOLEAN);  /*  If  not  a  number,  a  boolean      */ 

) 

/•••a-*********************  TConstant  *****************************/ 

PHITYPE 
tconstant  (ptr)  /*  Handle  constant  nodes  */ 

nodal  ptr; 
{extern  put_addr  (); 
PHITYPE  type;  /*  Constant  type  */ 

NameRec  *tptr;  /*  Constant  name  */ 

tptr  =  ptr->index; 

if  (type  =  convert  (tptr->name  +  1))  {  /*  Calculate  type  */ 

ptr->type  =  type; 

put_addr  (ptr,  type);  /*  Fill  node  &  increment  address   */ 

c_i_const  (tptr->name  +  1); 
return  (type) ;  } 

terror  (ERR_jj,  ptr->ln);  /*  No  legitimate  constant  found    */ 

} 
/*******************************  Tand.  ********************************/ 

PHITYPE 
tand  (ptr)  /*  Sem  Check  for  bool  and  node     */ 

nodal  ptr; 
{PHITYPE  ltype,  rtype; 

ltype  =  semcheck  (ptr->lptr) ; 
rtype  =  semcheck  (ptr->rptr)  ; 

if  (! (ltype  ==  BOOLEAN  &&  rtype  ==  BOOLEAN))     /*  Both  children  must  be  boolean   */ 
terror  (ERR_kk,  ptr->ln) ; 

c_store_code  ("call  land\n") ;  /*  Generate  code  */ 

return  (BOOLEAN)  ; 
} 
/it******************************  Tor  *****************************•*•*/ 

PHITYPE 
tor  (ptr)  /*  Sema  Check  for  bool  or  node     */ 

nodal  ptr; 
{PHITYPE  ltype,  rtype; 

ltype  =  semcheck  (ptr->lptr); 
rtype  =  semcheck  (ptr->rptr) ; 

if  (!  (ltype  ==  BOOLEAN  &&  rtype  ==  BOOLEAN))     /*  Both  children  must  be  boolean   */ 
terror  (ERR_kk,  ptr->ln) ; 
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c_store_code    ("call    lor\n");  /*    Generate    code  */ 

return    (BOOLEAN); 
} 

/•it****************************    Tneoation    *****************************/ 

PHITYPE 
tnegation    (ptr)  /*    Sema    check    for    neg   operation         »/ 

nodal    ptr; 
{ 

if  (!(semcheck  (ptr->rptr)  ==  BOOLEAN))  /*  Rt  child  must  be  a  boolean;     */ 

/*  It  child  is  null  */ 

terror  (ERR_kk,  ptr->ln) ; 

else  c_store_code  ("call  negat ion\n" ) ;  /*  Gen  code  for  boolean  negation   */ 

return  (BOOLEAN) ; 
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/a********************************************************************** 

*  PUBLIC  DOMAIN  SOFTWARE  * 

*  * 
Semcheck  Module  #4  * 
Sem4.c  * 
Maj  E.J.  COLE  /  Capt  J.E.  CONNELL  * 
01/29/87  * 
04/03/87  * 


*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 
••••••••••••a*********************************************************** 

*  This  file  contains  the  following  modules  for  the  PHI  compiler:        * 

*  * 

Telseif  * 

* 

*  * 

*  Algorithm  :  * 

*  This  module  contains  the  procedures  necessary  to  implement  the    * 

*  "if-then-elseif-else"  series  of  commands.   Tif  coordinates  the  seman-* 

*  tic  checking  by  calling  Tthen  to  check  its  left  nodes,  then  calling   * 

*  telse  to  check  its  right  nodes.   Telse  will  be  called  until  the  right* 

*  subtree  runs  out  of  "elses"  and  "elseif s" .  * 


Tif 
Telse 


Tthen 
Tcomp 


************************************************************************ 

*  Modified   :  * 

a**********************************************************************/ 

/**********************•***•*  Externals  *******************************/ 


#include  <semcheck.h> 
♦include  <string.h> 


/*  For  "strcpy" 


extern  FLAG  err_found; 
extern  PHITYPE  semcheck  (); 

extern  char  'name  (); 

extern  void  terror  (),  c_store_char  (); 

/a**************************  Globals  ****************************/ 
char  *if  label  =  NULL; 


/•it**************************  Tif  *******************************/ 

PHITYPE 
tif  (ptr) 

nodal  ptr; 
{extern  PHITYPE  numconvert  (); 
PHITYPE  type; 


/*  Semantic  checker  for  "if"  node  */ 
/*  Ptr  to  the  node  */ 

/*  Int,  Natural  to  real  converter  */ 


/*  Return  value  type 


■■I 


if  (if  label  ==  NULL)  if  label  =  malloc  (8); 


if_label  =  strcpy  (if_label,  name  0); 
type  =  numconvert  (ptr) ; 


/*  Generate   label  */ 

/*  Check  4  conv  It  and  rt  types    */ 


c_store_code  (if_label); 
c_store_code  (":\n"); 
return  (type) ; 


/*  Output  code  if  an  error 
/*  hasn't  been  found 
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/••it**********************  Tthen  ********************************/ 

PHITYPE 

tthen  (ptr)  /*  Sem  checker  for  then  node      */ 

nodal  ptr;  /*  Pointer  to  the  node            */ 

(PHITYPE  ltype,  rtype;  /*  Type  returned  from  left        */ 

char  'label  =  calloc  (7,1);  /*  Jump  for  asmlanguage  code      */ 

char  "holder  =  calloc  (7,1); 

strcpy  (holder, if_label)  ; 

if  (  (ltype=semcheck  (ptr->lptr) )  !=  BOOLEAN)     /*  Left  node  contains  condition;   */ 

/*  must  be  a  boolean  */ 

terror  (ERR_il,  pt r->ipt r->ln) ; 

if_label  =  strcpy  ( if _label, holder )  ; 

label  =  strcat  (label,  name  ());  /*  Get  a  label  for  assembly  code   */ 

c_store_code  ("call  igetvalue\n") ;  /*  Print  proper  code  */ 

c_store_code  ("cmp  ax,l\n"); 

c_store_code  ("jne  "); 

c_store_code  (label); 

c_store_code  ("\n"); 

rtype  =  semcheck  (ptr->rptr) ;  /*  Check  right  side  */ 

c_store_code  ("jmp  ")  ;  /*  Generate  code  */ 

c_store_code  (if_label); 

c_store_code  ("\n"); 

c_store_code  (label); 

c_store_code  (":\n"); 

return  (rtype);  /*  Right  type  is  returned         */ 

} 

/•it***********************  Telseif  a;*****************************/ 

PHITYPE 
telseif  (ptr)  /*  Sem  check  for  "elseif"  node     */ 

nodal  ptr;  /*  Ptr  to  the  node  */ 

{extern  PHITYPE  numconvert  ();  /*  Function  converts  and  returns   */ 

/*  left  and  right  types  */ 

return  (numconvert  (ptr)); 
} 

/it************************  xelse  ********************************/ 

PHITYPE 
telse  (ptr)  /*  Sema  checker  for  "else"  node    */ 

nodal  ptr; 
{ 

return  (semcheck  (ptr->lptr) ) ;  /*  Return  left  side;  */ 

/*  right  side  is  always  endif     */ 
} 

/A*************************  ^c  omp  *******•***********************/ 

PHITYPE 
tcomp  (ptr)  /*  Handle  comparisons  and         */ 

/*  set  membership  operations      */ 
/*  FOR  INTEGERS  AND  BOOLEANS  ONLY  */ 
nodal  ptr; 
{extern  PHITYPE  numconvert  (); 
PHITYPE  type; 
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type  =  numconvert  (ptr) 


switch  (ptr->name)    { 


case  (EQ_)    :  c_store_code  ("call  iequ\n"); 

break; 
case  (NEQ_)   :  c_store_code  ("call  ineq\n"); 

break ; 
case  (KW_  +  LESS_)  : 

c_store_code  ("call  ilt\n"); 

break; 
case  (KW_  +  GREATER_)  : 

c_store_code  ("call  igt\n") ; 

break; 
case  (LEQ_)   :  c_store_code  ("call  ilteq\n") 

break; 
case  (GEQ_)   :  c_store_code  ("call  igteq\n"), 

break; 
case  (KW_  +  IN_)  : 

c_store_code  ("call  in\n") ; 

break; 
case  (KW_  +  NOTIN_)  : 

c_store_code  ("call  notin\n"); 

break; 
default       :   terror  (ERR_11,  ptr->ln)  ; 
break ; 

} 
return  (BOOLEAN) ; 


/*  Check  and  convert  if  necessary  */ 

/*  THIS  IS  FOR  FUTURE  USE  WHEN     '/ 

/*  REALS  ARE  IMPLEMENTED  -/ 

/*  Check  cases  »/ 

/*  WORKS  ONLY  FOR  INTEGERS  AND     */ 

/*  BOOLEANS  NEEDS  REAL         */ 
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/•••••A**************************************************************** 
*  PUBLIC  DOMAIN  SOFTWARE  * 


Semcheck  Utilities. 1 

Sem_U.  c 

Maj  E.J.  COLE  /  Capt  J.E.  CONNELL 

01/02/87 

04/03/87 


*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 
••jt******************************************************************** 

*  This  file  contains  the  following  modules  for  the  PHI  parser:         * 

*  * 


* 

Putvar 

* 

Getfptr 

* 

Name 

* 

Putdef 

Putf orm 
Getvtype 
Getdtype 
And  Alloc 


Makef orm 
Finddef 
Form 
Add  And 


Findvar 
Put_addr 
Makevar 
Del  And 


•••••••A*************************************************************** 

*  Modified   :  * 

•••A******************************************************************/ 

/it***************************    Externals    ******************************/ 
#include    <semcheck.h> 

♦include    <stri.ng.h>  /*    for    "stpcpy"  */ 

/*****•***********************    Globals       it*****************************/ 
FLAG    err_found   =    FALSE;  /*    True    if    an    error    found  */ 

long    curr_addr    =    START_ADDR;  /*    Next    address    to    be    used   to  */ 

/*   place   a   variable  */ 

long   curr_scope    =    START_ADDR;  /*   Current    scope  */ 

form    =    FALSE;  /*    True    if    formals    being   processed*/ 

/********•■***■****:******•.    Typetable   Definitions    ************************/ 
int    typeptr    =    TYPE_INIT;  /*    Ptr   to    last   typetable    insert         */ 

tnode    types     [MAXTYPES];  /*    Typetable  */ 

/*•**•****••*•***********    Vartable   Definitions    ************************/ 
varptr    varhead   =   NULL;  /*    Head   of    varlist    linked    list  */ 

/******•***********•*****    Deftable   Definitions    ************************/ 

defptr    defhead   =   NULL;  /*    Head   of    deftable    linked   list         */ 

/****•******************    And   List    Definitions    it************************/ 
and_ptr    and_head    =    NULL;  /*    Head    for    and   list  */ 

and_flag    =    FALSE; 

/••it***************************   Makef  orm   ******************************/ 

f  node 
•makeform  ()  /*  Create  a  formal  node  */ 

{ 


return  ((fnode*)  calloc  (1,  sizeof  (fnode))) 


I 


/******************•**••****•  Put form  *********************************/ 

void 
putform  (type)  /*  Put  type  into  formal  list       */ 

PHITYPE  type; 
(extern  fnode  *fhead; 
fnode  *ptr  =  makeform  (),  /*  Make  a  formal  node  */ 

♦tracer;  /*  Tracer  for  the  formal  list      */ 
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ptr->type  =  type; 

if  (fhead  !=  NULL)  {  /*  If  list  already  exists 

tracer  =  fhead; 

while  (tracer->link  !=  NULL)  /*  Find  end  of  list 

tracer  =  t racer->link; 

tracer->link  =  ptr;  /*  Insert  Node 

ptr->link  =  NULL; 
} 

else  {  /*  If  no  list,  insert 

fhead  =  ptr; 
ptr->link  =  NULL; 
} 


} 


/••••it*************************  Makevar  a******************************/ 

varptr 
makevar  ()  /*  Make  node  for  vars  linked  1st   */ 

{ 

return  (struct  varnode*) 

calloc  (1,  sizeof  (struct  varnode)); 
} 

/••a***************************  Putvar  ********************************/ 

void 
putvar  (type,  treenode)  /*  Put  variable  in  vartable       */ 

PHITYPE  type; 

nodal  treenode; 

{extern  int  form; 
varptr  ptr  =  makevar  (); 

ptr->nptr  =  treenode;  /*  Fill  entry  */ 

ptr->type  =  type; 

ptr->form  =  form;  /*  Set  formal  flag  */ 

ptr->link  =  varhead;  /*  Set  top  of  linked  list         */ 

varhead  =  ptr; 

ptr  =  NULL;  /*  Free  pointer  space  */ 

free  (ptr) ; 
} 

/•it**************************  Findvar  *********************************/ 

varptr 
findvar  (varname)  /*  Find  var  in  vartable  */ 

long  varname; 

{varptr  ptr  =  varhead; 

while  (ptr  !=  NULL)   {  /*  Travel  list,  look  for  varname   */ 

if  (ptr->nptr->index  ==  varname)  /*  Break  if  variable  found        */ 

return  (ptr);  /*  Return  ptr  to  proper  varnode    */ 

ptr  =  ptr->link;   )  /*  Increment  link  */ 

return  (NULL) ;  /*  No  tally  on  variable  */ 
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/a***************************  Getvt VP©  it*******************************/ 

PHITYPE 
getvtype  (per)  /*  Get  type  of  var  in  var  stack    */ 

varptr  ptr; 

f 

return  (ptr->type) ; 

} 

/•it****************************  Putdef  ********************************/ 

void 
putdef  (type,  treeptr)  /*  Put  var  in  definitions  table    */ 

PHITYPE  type; 

nodal  treeptr; 
(extern  int  form; 

defptr  ptr  =  (struct  def node* ) calloc ( 1, sizeof  (struct  defnode)  )  ; 

ptr->nptr  =  treeptr;  /*  Fill  entry  */ 

ptr->type  =  type; 

ptr->link  =  defhead;  /*  Set  top  of  linked  list         */ 

def he ad  =  ptr; 

ptr  =  NULL;  /*  Free  pointer  space  */ 

free  (ptr) ; 
} 

/**********•*****•**••*•**•**  Finddef  *********************************/ 

defptr 
finddef  (varname)  /*  Find  var  in  deftable  */ 

long  varname; 
{defptr  ptr  =  defhead; 

while  (ptr  !=  NULL)   { 

if  (ptr->nptr->index  ==  varname)  /*  Break  if  variable  found        */ 

return  (ptr) ;  /*  Return  ptr  to  proper  varnode    */ 

ptr  =  ptr->link;   } 

return  (NULL);  /*  No  tally  on  variable  */ 

} 

/•it***************************   get f pt r    ********************************/ 

f  node 
'getfptr    (ptr)  /*    Return    fptr    from   def    table  */ 

defptr    ptr; 
{ 

return     (ptr->fptr) ; 
} 

/it***************************   Getdt vpe    ********************************/ 

PHITYPE 
getdtype    (ptr)  /*   Get    type    of    var    in   def    table        */ 

defptr    ptr; 
{ 

return    (ptr->type) ; 
} 

/•••a************************  Add  and   *********************************/ 

void 

add_and    (ptr)  /*   Add   and_node   to    and    list                  */ 

nodal    ptr;  /*    Ptr   to    node   containing   var             */ 
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{extern  and_ptr  and_head,  and_alloc  (); 
extern  int  buff_ptr; 
and  ptr  a_ptr  =  and_alloc  ();;  /*  Holder  for  and  ptr  */ 

a  ptr— >buffptr  =  buff_ptr;  /*  Set  ptr  to  current  buffer  ptr  */ 

a  ptr->ptr  =  ptr;  /*  Get  ptr  to  node  with  var  def  */ 

a_ptr->link  =  and_head;  /*  Link  node  to  list  */ 
and_head  =  a_ptr; 

a_ptr  =  NULL;  /*  Dispose  of  a_ptr  */ 

free  (a_ptr) ; 
} 

/******************************  And.  Alloc  *****************************/ 

and_ptr 
and_alloc    {)  /*   Create   a    node    for    and    list  */ 

{ 

return    ((struct    and_struct *) calloc    (1,    sizeof    (struct    and_struct ) ) ) ; 
} 

/••it****************************   Del   and.   ******************************/ 

void 
del_and  (ptr)  /*  Delete  entry  into  the  and  list  */ 

and_ptr  ptr; 
{extern  and_ptr  and_head; 
and_ptr  search  =  and_head; 

if  (ptr  !=  and_head)  {  /*  Case  if  pointer  not  equal  to    */ 

/*  first  entry  in  list  */ 

while  (search->link  !=  ptr)  /*  Place  ptr  on  entry  above       */ 

/*  tgt  entry  */ 

search  =  search->link; 

search->link  =  ptr->link;  /*  Set  pointer  */ 

} 

else  and_head  =  ptr->link;  /*  Case  ptr  =  to  1st  entry  in  1st  */ 


ptr->link  =  NULL;  /*  Dispose  of  uneeded  node         '/ 

free  (ptr)  ; 


} 


/•it**-***************************  Terror  *******************************/ 

void 

terror  (err_num,  line_num)                        /*  Sem  check  error  handling  */ 

/*  routine  */ 

int    err_num,    iine_num; 
{extern    ErrorHandler    (); 

err_found   =   TRUE;                                                                           /*  Set    err_found   to   true    &  */ 

/*  stop   code   gen  */ 

ErrorHandler    (line_num,    err_num,    SEM_ERR) ;               /*  generic   error    handling   proc  */ 
} 

/•it****************************    Putaddr    *******************************/ 

void 

put_addr  (ptr,  type)                              /*  Inserts  virtual  address  of  */ 

/*  variable/function  return  */ 

/*  And  increments  curr_addr  */ 

/*  Assumes  global  curr_addr  */ 

nodal  ptr;                                      /*  Pointer  to  target  node  */ 
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PHITYPE  type;  /*  Node  type  */ 

{ 

ptr->addr  =  curr_addr;  /*  Set  node  address  */ 

ptr->scope  =  curr_scope; 

curr_addr  =  curr_addr  +  (types  [type] .bytes ) ;   /*  Increment  curr_addr  by  num  of  */ 

/*  bytes  type  needs  */ 

if  (curr_addr  >  MAXADDR)  /*  Error  if  address  exceeds       */ 

/*  address  space  */ 

terror  (ERR_mm,  ptr->ln) ; 
} 

/*********************************  Name  ******•********•**************•/ 

char 
•name  ()  /*  Generate  an  appropriate  name    */ 

/*  for  a  label/  procedure         */ 
( 
char  'string  =  malloc  (7),  /*  Holder  for  output  */ 

*stringl  =  malloc  (7); 
static  long  seed  =  10000;  /*  Number  to  append  to  string     */ 

"string  =  'a';  /*  String  prefix  */ 

"(string  +  1)  =  ENDSTRING;  /*  Insert  string  terminator  */ 

stcl_d  (stringl,  seed);  /*  Convert  long  seed  to  string  */ 

string  =  strcat  (string,  stringl);              /*  Concatenate  strings  */ 

++seed;  /*  Incr  int  to  avoid  duplication  */ 
return  (string); 
} 

/•it*****************************  pq rma  1  *******************************/ 

FLAG 
formal  (ptr)  /*  Returns  true  if  the  varnode        */ 

/*  describes  a  formal  */ 

varptr  ptr; 
{ 

if  (ptr->form)  return  (TRUE) ; 
else  return  (FALSE) ; 
} 
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APPENDIX  K 
ROCK  COMPILER  —  CODE  GENERATION  MODULE 


/•••A****************************************************************** 

*  PUBLIC  DOMAIN  SOFTWARE  * 

*  * 


Code  Generation  Module 

Code_Gen . c 

Maj  E.J.  COLE  /  Capt  J.E.  CONNELL 

02/06/87 

04/10/87 

04/13/87   Code  output  to  vdisk    EC 


*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 
•••••••A*************************************************************** 


*  This  file  contains  the  following  modules  for  the  PHI  compiler 
* 


* 

C_Store_Code 

* 

C  Ending 

* 

Ac  ode 

* 

C_I_Const 

* 

C_I_Op 

C_Startup 
C_Printcode 
C_Jmp 
C_I_Form 
C  Call  Proc 


C_Of f_Insert 
C_Ztor 

C_Start_Proc 
C  End  Proc 


*  Algorithm  :  * 

*  This  module  contains  the  procedures  necessary  for  code  generation.  * 

*  C_startup  initializes  the  run_time  file,  &  the  semantic  checker  will* 

*  call  the  procedures  as  necessary.  Note  that  "c_store_code"  is  a  * 

*  genaric  generator  which  will  spew  any  string  given  as  an  arg  to  the  * 

*  output  file.  * 

*  * 
********************************************************** 

*  Modified   :   04/13/87   Code  output  to  vdisk.,  drive  "d:"    EC  * 
*************************************************** 

/••it*************************    Externals    *********************•***•****/ 

#include    <semcheck.h> 

♦include   <string.h> 

♦include    <fcntl.h>  /*    For    level    1    I/O  */ 


extern    FLAG   err_found; 
extern    long    curr_addr; 


/*  Error  flag 

/*  Current  virtual  address 


/•it****************************  Globals  ******************************/ 

char  *code_buf fer ;  /*  Buffer  for  output  code         */ 

int  buffjptr  =  NULL;  /*  Ptr  to  chars  in  output  buffer   */ 

/****************••*•**********  q   store   Code    *************************/ 

void 

c_store_code    (string)  /*    Put    str    into   the    output    buffer    */ 

char    *string;  /*    String   to    be   printed                           */ 

(int    ptr    =   NULL;  /*    Ptr    to   the    chars    in    input    str      */ 
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if  (!err_found)  {  /'  Compute  only  if  no  error  found  */ 

while  ('(string  +  ptr)  !=  NULL)  {  /*  Copy  string  char  by  char        */ 

* (code_buf fer  +  buff_ptr)  =  * (string  +  ptr); 

-f  +  ptr; 

+^buff_ptr;  } 

} 
} 

/■it*****************************  q  Jmp  ********************************/ 

void 
c_jmp  (name)  /*  Gen  code  to  insert  jump  command*/ 

char  'name; 
{ 

c_store_code    ("jmp    "); 
c_store_code    (name); 
c_store_code    ("\n"); 
} 
/•it**************************    q    Start    Proc    ***************************/ 

void 
c_start_proc    (name)  /*   Output    name    for    start    of    asm        '/ 

/*    language    procedure  */ 

char    *name; 
( 

c_store_code    (name); 
c_store_code    (":\n"); 
) 

/••••••it*********************    q    End   Proc    *****************************/ 

void 
c_end_proc  (name)  /*  Output  name  for  ending  an      */ 

/*  assembly  language  procedure     «/ 
char  'name; 
{ 

c_store_code  ("call  del_scope\n") ; 
c_store_code  ("ret\n"); 
c_store_code  (name); 
c_store_code  (":\n"); 

/A***************************    q    Call    Proc    ****************************/ 

void 
c_cali_proc    (name)  /*   Output    call    for    an    assembly  */ 

/*    language   procedure  '/ 

char    'name; 

c_store_code  ("call    ") ; 

c_store_code  (name); 

c_store_code  ("\n"); 

; 

/••A*************************    q    j    Form    ** ***************************** / 

void 
c_i_form  (num)  /*  Generate  call  to  put  integer    '/ 

/*  formal  addr  onto  stack         '/ 
char  *num; 
{ 

c_store_code  ("mov  ex,"); 
c_store_code  (num); 
c_store_code  ("\n"); 
c  store  code  ("call  i  formal\n"); 
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/•a**************************  q   i  Const  ******************************/ 

void 
c  i  const  (name)  /*  Output  code  for  assigning  an    */ 

/*  integer  constant  */ 

char  *name; 
{ 

c  store_code  ("mov  ax,"); 
c_store_code  (name) ; 
c_store_code  ("\n") ; 
c_store_code  ("call  iputvalue\n" ) ; 
} 
/a***************************  q    i  op  *********************************/ 

void 
c_i_op  (op)  /*  Output  code  for  int  arith  ops   */ 

optype  op;  /*  Type  of  operation  */ 

{extern  void  terror  ( )  ; 

switch  (op)  { 

case  (ADD)  :  c_call_proc  ("iadd"); 

break; 
case  (SUB)  :  c_call_proc  ("isub"); 

break; 
case  (DIVIDE)  :  c_call_proc  ("idivn"); 

break; 
case  (MULT)  :  c_call_proc  ("imult") ; 

break; 
default  :  return; 
} 


/*********•****•********  startup  **** 

void 

c_startup  () 

{   code_buffer  =  getmem  (SIZEBUFFER) ; 

c  store  code  ( 

'extrn 

initial 

near\n") ; 

c  store_code  ( 

'extrn 

iadd 

near\n") ; 

c  store  code  ( 

'  e  xt  r  n 

isub 

near\n") ; 

c  store  code  ( 

'extrn 

imult 

near\n") ; 

c  store  code  ( 

'extrn 

idivn 

near\n") ; 

c  store  code  ( 

'extrn 

iequ  :  near\n") ; 

c  store  code  ( 

'extrn 

ineq  :  near\n" ) ; 

c  store  code  ( 

'extrn 

igt  :  near\n") ; 

c  store  code  ( 

'extrn 

ilt  :  near\n") ; 

c  store  code  ( 

'extrn 

land  :  near\n") ; 

c  store  code  ( 

'extrn 

lor   :  near\n" ) ; 

c  store  code  ( 

'extrn 

igteq  :  near\n" ) ; 

c  store  code  ( 

'extrn 

iputvalue  :  near\n' 

c  store  code  ( 

'extrn 

ilteq  :  near\n") ; 

c  store  code  ( 

'extrn 

igetvalue  :  near\n' 

c  store  code  ( 

'extrn 

initial  :  near\n"); 

c  store  code  ( 

'extrn 

finis  :  near \n" ) ; 

c  store  code  ( 

'extrn 

print  top  :  near\n' 

c  store  code  ( 

'extrn 

negation  :  near\n") 

c  store  code  ( 

'extrn 

i_formal  :  near\n") 

c  store  code  ( 

'extrn 

i  mov  :  near\n" ) ; 

c  store  code  ( 

'extrn 

ppush  :  near\n") ; 

c  store  code  ( 

'extrn 

ppop  :  near\n") ; 

c  store  code  ( 

'extrn 

add  scope  :  near\n' 

c  store  code  ( 

'extrn 

del  scope  :  near\n' 

c  store  code  ( 

•org  0100h\n\n")  ; 

c  store  code  ( 

'cseg\n 

')  ; 

c  store  code  ( 

"call  initial\n" 

; 

•  ••it****************************/ 

/*  Open  and  initialize  files 

/*  Initialize  buffer 

/*  Write  utilities  needed 
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/***********************  q   Print  Code  ****************************•/ 

void 
c_print_code  ()  /*  Output  code  buffer  to  */ 

/*  secondary  storage  */ 

(extern  char  prefix  []; 
int  code;  /*  Output  file  */ 

char  holder [30] ; 

strcpy  (holder,  "d:");  /*  set  up  file  name  «/ 

strcat  (holder,  prefix) ; 

strcpy  (prefix,  holder);  /*  save  prefix  &  drive  for  fut  use*/ 

strcat  (holder,  "a. 86"); 

code  =  open (FILENAME, 0_TRUNC  i  0_WRONLY, NULL) ;  /*  Open  file  for  writing  and       */ 

/*  overwriting  only  */ 

write  (code,  code_buffer,  buff_ptr);            /*  Write  the  buffer  */ 

close  (code);                                 /*  Close  the  output  file  »/ 
} 

/A***********************  q      Endincr  ******************************** / 

void 
c_ending  ()  /*  Ending  for  output  code         */ 

{ 

if  ( ! err_f ound)  { 

c_store_code  ("call  print_top\n") ; 
/*  Print  address  pointed  to  by   */ 

/*  top  of  program  stack  */ 

c_store_code  ("call  finis\n") ;  /*  Routine  to  make  clean  ending    */ 

* (code_buf fer  +  (buff_ptr  ++) )  =  CNTRL_Z;     /*  If  no  error,  put  asm  language   */ 

/*  delimiter  to  file  */ 

c_print_code  ();  /*  Output  code  to  a  file  */ 

} 
> 

/it**************************  q    ztor  ********************************/ 

void 

c_ztor  ()  /*  Gen  code  for  conv  int  to  real   */ 

{}  /*  Empty  now,  but  watch  our  smoke  */ 

/A***************************  p^Q ode  *****************************/ 

void 
acode  (ptr,  type)  /*  NOTE  :  USES  EMPTY  STATEMENTS    */ 

/*  FOR  REAL  OPERATIONS  */ 

nodal  ptr; 

FLAG  type;  /*  Generate  code  for  arith  ops     */ 

(extern  void  terror  (); 
int  name; 

name  =  ptr->name; 

switch  (name)  { 

case  (ADD_)  :  if  (type  ==  REAL) ;  /*  Addition  */ 

else  c_i_op  (ADD) ; 
break; 
case  (SUB_)  :  if  (type  ==  REAL) ;  /*  Subtraction  */ 

else  c_i_op  (SUB) ; 
break; 
case  (MULT_)  :  if  (type  ==  REAL);  /*  Multiplication  */ 

else  c_i_op  (MULT) ; 
break; 
case  (RDIV_)  :  /*  Real  Division  */ 

break; 
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case  (IDIV_)  :  c_i_op  (DIVIDE); 

break; 
} 


/*  Integer  Di 


lvision 
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APPENDIX  L 
ROCK  COMPILER  —  USER  INTERFACE 


/ 


********************************************************************** 


User  Interface 

User .C 

Maj  E.J.  COLE  /  Capt  J.E.  CONNELL 

04/01/87 

04/10/87 


*  Name 

*  File 

*  Authors 

*  Started 

*  Archived 

*  Modified 
*********************************************************************** 

*  This  file  contains  the  following  modules  for  the  PHI  compiler        * 


User_err 
Print  header 


Get name 
P  Close 


Prog_name 
User 


*  Algorithm  :  * 

*  This  module  contains  the  procedures  necessary  for  the  user  in-  * 

*  terface.  * 

*  Prog_Name  gets  the  user's  choice  of  program  by  calling  Get_Name  * 

*  Print  header  is  called  to  print  the  initial  screen  display  on  con-  * 

*  sole,  &  the  User  procedure  is  the  overall  coordinator  of  the  inter-  * 

*  face.  * 

*  User_Err   and   P_Close    are   both    independent   procedures.      User_Err  * 

*  handles    output    in   the    event    that    an   error    or   errors    have   been    found.* 

*  P_close    is    called  by    "Rock._Main"    to   ensure    the    input    file    has    been  * 

*  closed.  * 

*  * 

******************************************************************** 

*  Modified      :  * 
********************************************************************* 

/******************************   Externals    ****************************/ 
#include    <user.h> 

^include    <dos.h>  /*    for    "getch    ()"  */ 

^include    <stdio.h> 

extern    void   clrscr     (),    mov_cursor     (),    c!r_window    (); 

/*******************************    Globals    ******************************/ 


char  u_name  [BUFFLENGTH] , 
prefix  [BUFFLENGTH]; 

FILE  "infile; 


/*  Name  of  Source  file  */ 

/*  Prefix  of  source  file  */ 

/*  File  handle  of  source  file     */ 


/******************************  User  Err  ******************************/ 

void 
user_err  () 
{extern  void  clrscr  (); 


/*  Screen  interface  for  error  rnsg  */ 
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extern  int  num_errors;  /*  Number  of  errors  found  */ 

FILE  *errors;  /*  Error  File  */ 

int  numblocks,  /*  Number  of  blocks  to  read  */ 

count  =  0;  /*  Generic  loop  variable  */ 
char  *buffer  =  malloc  (BSIZE), 

input;  /*  Keypressed  after  pause  */ 

errors  =  fopen  (ERRORFILE, "a") ; 
fprintf (errors, 

"number  of  errors  =  %d\n", num_errors) ; 
putc  ('$',  errors);  /*  Put  EOF  marker  to  file         */ 

fclose  (errors) ; 

c  1  r  s  c  r  ( )  ; 

errors  =  fopen  (ERRORFILE,  "r") ; 

numblocks  =  f read (buffer, BLOCKSIZE, 20,  errors)  ;  /*  Read  error  mgs  from  error  files*/ 

/*  BLOCKSIZE    will  allow  whole    */ 
/*  file  to  be  read  at  once        */ 
while  ('(buffer  +  count)  !=  ■$')  { 
putchar  (* (buffer  +  count) ) ; 
++count;  } 

printf  ("\n  \n  \n") ;  /*  Skip  lines  to  give  appearance  */ 

/*  of  user  friendliness  */ 

printf  ("%s",  PAUSE);  /*  Pause  to  give  user  a  chance  to  */ 

/*  comtemplate  his  errors  */ 

input  =  getch  ();  /*  Eat  keyboard  input  after  pause  */ 

fclose  (errors) ; 
c  1  r  s  c  r  ( )  ; 

if  (input  ==  ESCAPE)  exit  (I);  /*  If  user  pressed  escape,         */ 

/*  exit  the  program  */ 

} 

/********************************  Getname  it****************************/ 

void 
getname  ()  /*  Returns  the  user's  choice       */ 

/*  of  file  to  compile  */ 

{int  ch,  /*  Single  input  character         */ 

count  =  0;  /*  Buffer  pointer  */ 

do  {  /*  Loop,  get  file  name  ltr  by  Itr  */ 

if  ( (ch  =  getch  ())  ==  BACKSPACE)  {  /*  <-  key  is  hit  */ 
if  (count)  {  --count; 

putchar  (ch) ;  /*  Backspace  */ 

putchar  ('  ');  /*  Insert  blank  */ 

putchar  (ch) ;  /*  Eat  last  char  if  there  is  one   */ 
}                  } 

else  if  (ch  ==  ESCAPE)  (  /*  Escape  pressed;  exit  */ 

cirscr  ( ) ; 
exit  (1) ;  ) 
else  if  (ch  <  127) 

(  /*  Legitimate  char  read;  use  it    */ 

putchar  (ch) ; 
u_name  [count]  =  ch; 
+xcount;  } 

)  while  ((count  <=  BUFFLENGTH)  && 

ch  !=  EOLN) ;  /*  Loop  until  buffer  full  or       */ 

/*  return  pressed  */ 
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u_name    (count    -    1]    =    0;  /*    Insert   end   of    string    char  */ 

} 

/it*****************************    Proo   name    *****************************/ 

void 
prog_name  ()  /*  Get  legitimate  program  name     */ 

{ 

do  f  /*  Loop  until  foper.  finds         */ 

/*  legit  name  */ 

clr_window  (9,1,21,79);  /*  Clear  out  lower  window  of  sen   */ 

mov_cursor  (10,2); 
printf  (GETPROGRAM) ; 
getname  ( ) ; 
infile  =  fopen  (u_name,  "r") ; 

if  (! infile)  {  /*  Name  not  in  current  directory   */ 

mov_cursor  (20,33);  /*  Print  user  friendly  error  msgs  */ 

printf  (FILE1_ERRCR) ; 
mov_cursor  (21,  16); 
printf  (FILE2_ERROR) ; 

if  (getch  ()   ==  ESCAPE)  {  /*  Exit  if  ESCAPE  pressed  */ 

c  1  r  s  c  r  ( )  ; 
exit  (1) ; 

} 
} 
}  while  (! infile);  /*  Repeat  until  correct  file  found*/ 

/*  NOTE  -  escape  exits  loop  &  prgm*/ 
mov_cursor  (13,28); 
printf  (WAIT) ; 
} 
/•it**************************  Print  header  ****************************/ 

void 
print_header  ()  /*  Print  out  header  for  user      */ 

( 

c  1  r  s  c  r  ( )  ; 
mov_cursor  (1,33); 
printf  (HEADER1); 
mov_cursor  (2,24); 
printf  (HEADER2) ; 
} 

/•it****************************  p  close  *  *^*** ************************* / 

void 
p_close  ()  /*  Close  out  target  file  */ 

( 

f close  (  infile) ; 
) 
/•****•**************************  user  ********************************/ 

void 
user  ()  /*  Invoke  user  interface  */ 

(int  count  =  0;  /*  Duty  integer  */ 

print_header  ( ) ; 

prog_name  ( ) ; 

while  ( !  (u_name  [count]  ==  '  .  '  /*  Copy  root  of  input  file  name  */ 

I  I  u_name  [count]  ==  NULL))  {  /*  Loop  until  end  of  input  name  */ 

/*  reached  OR  until  end  of  str  is  */ 

prefix  [count]  =  u_name  [count];  /*  reached,  if  no   extension  */ 

++count;  } 

prefix  [count]  =  0;  /*  Insert  end  of  string  value  */ 
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APPENDIX  M 
ROCK  COMPILER  —  RUNTIME  UTILITIES 


*********************************************************************** 

*  Name  :  Phi  Runtime  Utilities  * 

*  File  :  U.a86  * 

*  Authors  :  Maj  E.J.  COLE  /  Capt  J.E.  CONNELL  * 

*  Started  :  01/26/87  * 

*  Archived  :  16  Feb  87  * 

*  Modified  :  16  Apr  87  Stack/Varspace  Crash  error  check  EC          * 
*********************************************************************** 

*********************************************************************** 
ALGORITHMS 


1. 


Input/Output:   The  first  section  of  the  program  contains  input  and  output 


2.  Virtual  Space:   A  virtual  space  is  set  up  in  the  extra  segment  to  hold  both  the 
stack.   The  middle j  of  this  space  is  denoted  by  the  symbol  "vars",  and  variables 
offset  (±  32700)  from  vars.   In  this  implementation,  the  program  stack  grows  from 
vars  grow  from  the  bottom.   The  virtual  space  is  assumed  to  be  made  up  of  words 

two  bytes),  so  only 

even  numbers  may  be  used  to  access  it. 

3.  Stack:  The  stack  pointer  is  the  si  register,  which  is  initialized  to  3270C. 
grows,  the  si  register  is  reduced  by  two.  Ppush  and  ppop  will  push  ana  pop  two 
registers.  "Push_one"  and  "Pop_one"  will  push  and  pop   single  words  to  and  from 

4.  Addressing  Program   Variables:  Each  program  variable  is  assigned  a  two-tuple  A 
scope  and  0  is  the  offset  from  the  base  address  of  variables  in  that  scope. 

turn  the  address  of  a  variable  given  A. 

5.  Scoping:   Initially  the  scope  is  set  to  0:  the  global  scope.   The  variable 
space  containing  the  outer  scope,  and  the  variable  "S_Nest"  contains  the  current 
new  scope  is  created,  "S_Nest"  is  increased  by  one,  and  the  three-tuple  S  = 

(L  =  Static  Link,  pointing  nesting  level  of  the  outer  scope,  N  is  the  nesting 

is  the  base  address  of  display  of  variables  for  this  scope. 

When  a  scope  is  deleted,  the  top  of  the  stack  is  saved,  the  top  instantiation  of  5 

and  S_Link  and  S_Nest  are  recalculated. 

6  Inserting/Extracting  Program  Variables:  "I_Assign"  will  insert  an  integer  or 

scope  contained  in  S_Nest  when  it  is  requested.   "Iputvaiue"  will  insert  the 

resoponding  tuple  A  on  the  stack.   "Igetvalue"  will  pop  the  tupie  A  off  the  top  of 
the  value  of  the  integer  pointed  to  by  A. 

*********************************************************************** 
*********************************************************************** 

*  Modified   :  22  Feb  87  Add/del_scope  changed  to  save  TOS .  EC         * 

*  16  Apr  87  Added  check  for  stack/varspace  crash,  includes* 

*  message  to  observer  * 
*********************************************************************** 
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.••it******************************************************************** 

;  *  Public  Procedures  * 

.•it********************************************************************* 

public  i_mov 
public  i_formal 
public  igetvaiue 
public  finis 
public  iputvalue 
public  find_addr 
public  add_scope 
public  del_scope 
public  initial 
public  finis 
public  ppush 
public  ppop 
public  iassign 
public  lor 
public  land 
public  iequ 
public  ineq 
public  ilt 
public  igt 
public  ilteq 
public  igteq 
public  negation 
public  iadd 
public  isub 
public  imult 
public  idivn 
public  print_top 

A****************************************************************** 

*  * 

*  I/O   Procedures  * 

*  * 
******************************************************************* 

***********************    print    char    ******************************** 

Print    a    char    to    the    screen 

assumes    letter   to   be   printed   is    in   dl    register 


print_char : 
push    ax 
mov   ah, 06 
int    21h 
pop   ax 
ret 


/save    registers 
;put    int   vector 


*************************    Eoln    ********************************* 
Prints    end   of    line    character    to   the    screen 


eoln:        mov   dl,    10 
call   print_char 
mov  dl,     13 
call    print_char 
ret 


/Moves    appro    ascii    values    to    crt 
/ IBM    specific 


*********************    Print    Num.    ******************************** 
Prints,    as    a    number,    the    value    found   in   the   bx    register 
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print_num:      push  ax 
push  bx 
push  ex 
push  dx 
mov  ex,  10000 
emp  bx, 0 
jge  small 

mov  dx,  '  - 
call  print_char 

neg  bx 

small:     emp  bx,  10 
jl  final 


rBase  for  dividing 
:Check  if  negative 
r If  not,  jump  to  start 
rEmit  negative  sign 

r Negate 

rtest  if  less  than  10 


div_loop:   mov  ax, 
xor  dx,  dx 


bx 


div 

ex 

emp 

ax, 

0 

jne 

P_l 

oop 

mov 

ax, 

ex 

mov 

ex, 

10 

xor 

dx, 

dx 

div 

ex 

mov 

ex, 

ax 

Divide  bx  by  ex 
Set  up  dx  register 


rlf  not  zero,  jump 

^Otherwise,  deer  ex  by  factor  of  10 


Mov  ax  to  ex  and  continue 


jmp  div_loop 


p  loop:   mov 

ax,  bx 

xor  dx,  dx 

div  ex 

mov  bx,  dx 

add  ax,  4  8 

mov  dx,  ax 

call  print 

char 

xor  dx,  dx 

mov  ax,  ex 

mov  ex,  10 

div  ex 

mov  ex,  ax 

emp  ax,  1 

jne  p  loop 

final : 

add  bx,  4  8 

mov  dx,  bx 

call  print 

char 

call  eoln 

pop  dx 

pop  ex 

pop  bx 

pop  ax 

ret 

•Main  printing  loop 

•Set  up  dx  register 

i  Divide 

•Move  remainder  to  bx 

•Add  for  ascii 

•Print 

•Set  up  dx  for  division 
•Divide  base  value  by  10 


If  base  value  1,  end  loop 
Else  continue 


Print  final  value 


End  of  line 


**********************    Print    too    ******************************* 
Prints   the   space   pointed  to   by   the   top   tuple   of   the   program   stack 


prir.t_top : 

add  di, 2 

mov   dx,    vars [di 

add   di,2 

mov   ex,    vars [di 


mov  di , si 


;Get    nesting    level 
;Mov    offset    to    ex 


147 


call    find_addr  ;Mov   address    into    si    reg 
mov  di,    ex 

mov   bx,    vars    [di]  ;Mov   num    from   address   to    ox 

call   print_num  ; Print    number 

call   eoln  ; Inset    eoln 
ret 
*************************    print    s    ****************************** 

assumes    address    of    is    in   the   dx    register 
assumes    string  ends    with   a    "$"    sign 


push    ax  /save    register 

mov   ah,     9 

int    21h 

pop   ax 

ret 

******************************************************************* 

*  * 

*  Stack    Procedures  * 

*  * 
******************************************************************* 

*************************    ppush    *********************************** 
Pushes    values    from  ex    (offset)    and  di    (nesting    level) 

ppush:        mov   vars    [si],  ex                                              ;Put    offset    in    stack 

sub   si,    2  ; Inc    stack    pointer 

mov  vars    [si],    di  ;Put    Nest    level    into    stack 

sub   si,    2  ; Inc    stack   pointer 

emp   si,    curr_addr  ;Check    for    stack/varspace    crash 

jg   p_return  ;If    no    crash,    go    to   end 

mov  dx,    offset    crash  ;Get    string    for   error   message 

call    print_s  ;Print    it 

call    finis  ;Hait    execution 

p_return:  ret 

*************************    Push    one    ***************************** 
Push    a    single    integer    from  ex    register   to   the   program   stack 

push_one:  mov  vars    [si],    ex  ;  Put    word   in    stack 

sub    si,    2  ; Inc    stack    pointer 

ret 

**************************     ppop     ******************************** 

Pop    values    from  the   program   stack   to   di    (nesting   level)    and   ex    (offset) 

ppop:  add    si, 2  ; Set    up   ptr 

mov  di,    vars  [si]  ;Get    nesting    level 

add   si, 2  ;Recalc   pointer 

mov   ex,    vars  [si]  ;Get    offset 

ret 

*************************   Pop   One    ****************************** 
Pop    a    single    integer    from  the    stack   to    the    ex    register 

pop_one:  add    si,    2  ; Set    up   pointer 

mov   ex,    vars    [si]  ;Get    word 
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******************************************************************* 

*  Varspace  Management    Procedures  * 
******************************************************************* 

***********************    i As s ign    *********************************** 
Assign   an    integer   value   to   a   variable   space    in   current    scope 
Assumes    value    is    in    ax;    offset    is    set    to    current    max   offset 

iassign:  mov  di,    s_link 

;get    static    link 

sub   di,2  /decrement    it    to    pt    to    base    address 

mov   di,    varsfdi]  ; mov   base    address    to   di 

add   di,    max_offset  ; add   offset 

mov   vars[di],    ax  ;mov   number    into   that    address    space 

add  max_offset,2  ; Inc   max   offset    and   current    address 

add   curr_addr , 2 

ret 

. ************************    igetvalue    ***************************** 
;Pop   the    stack   and  move   the    integer   value   pointed  to    into   the   ax 
register 

igetvalue:  call   ppop;  ;Get    nesting    level    and   offset 

mov  dx,    di 

call    find_addr  ;Get    addr   of    (S_Nest,    Max_Offset) 

mov  di,    ex 

mov   ax,    vars    [di]  ;Get    integer    value 

ret 

***********************  iputvalue  ****************************** 
Takes  an  integer  from  AX  register,  puts  its  value  into  varspace, 
then   puts    its    address    on   the   top   of   the   stack 

iputvalue:         mov    dx,     s_nest  ;Get    static    nesting    level 

mov   ex,    max_offset 

call    find_addr  ;Get    addr    of    (S_Nest,    Max_Offseti 

mov   di, ex 

mov  vars    [di],    ax  ;Put    value    into   memory 

mov  di,    s_nest 
mov   ex,    max_offset 

call    ppush  ,-Store    (S_Nest,    Max_Offset) 

add   max_offset,    2  ;Inc   max   offset    and   curr_addr 

add   curr_addr,    2 
ret 

******************************************************************* 

*  * 

*  Scoping   Procedures  * 

*  * 
******************************************************************* 

*********************    Find  Addr    *********************************** 
Returns    address    of    variable    at    nesting    level    dx,    offset    ex   to    ex    reg 

find_addr:     mov  di,    s_link  ;Get    addr    of    current    static   pointer 

find_loop:     emp   es : vars [di j , dx  ;If    stack    value    =    scope,    exit    loop 

je    f_out 
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add  di, 2 

mov  di,  es:vars[di]  ;Else  jump  to  next  scope  ar.d  loco 

jmp  find_loop 

f    out:            sub   di,2  ;Calc   ptr   to   base    addr    of    scope    vars 

add   ex,    es:vars[di]  ;Add   offset 
ret 

.********************   Add   Scope  ************************************ 

; Start    new   scope   by   adding   static    link,    starting   address,    &    nesting 
level 

add_scope:     mov   ex,    s_link  ; Get    static    link 

inc   s_nest 

mov  di,    s_nest  ;Get    new   nesting    level 

call    ppush  ;Save    link    and    level 

mov   ex,    curr_addr 
mov  di,    max_offset 

call    ppush  ;Save    curr    addr 

mov  max_offset,    0  ; Re    initialize   max   offset 

mov   s_link,    si 
add    s_link, 6 
ret 

********************    dq]_    Scope    ************************************ 
Deletes    a    scope 

del_scope:     call    ppop;  ;Save   top   of    stack 

mov   dx,    di 
call    find_addr 

push    ex  ; Save    absolute    address    of    tos 

dec    s_nest  ; Reduce    nesting   level 

mov   si,    s_link  /Decrease    stkptr    to    current    link 

sub    si,     4 

mov   ex,    es:vars    [si] 
mov  max_offset,    ex 
mov   bx, 2 

mov   ex,    es:vars     [si+bx] 
mov   curr_addr,    ex 
add   si,     6 

mov   ex,    es:vars    [si] 

mov    s_link,    ex  ; Get    current    static    link 

pop   di 

mov   ax,    es:vars    [di]  /Restore    top   of    stack 

call    iputvalue 
ret 

******************************************************************* 

*  * 

*  Begin/End  Procedures  * 

*  * 

******************************************************************* 

************************  initial  ********************************** 

initialize   the   stack,   and  variables 

must    initialize    ex   to   base    of    stack    heap   before    calling   this 

initial:  mov    si,    SPACE_TOP  /Initialize   base    of    stack 

mov   di, 0 
mov   ex,    0 

call   ppush  /Push   base_scope    and   address 

ret 
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***********************    finis    ********************************** 

finis: 

mov   ax,04c00h  ;end   procedure 

int    21h 
ret 
***************************************************************** 

*  Booleans  * 

***************************************************************** 

*************************  Necrat ion  ****************************** 
Negates  a  boolean  value 

negation:    call  igetvalue  ;Get  boolean 

cmp  ax,  1 
jne  zero 
mov  ax, 0 

jmp  p  ; Jump  to  end 

zero :   mov  ax, 1 

p:  call  iputvalue  /Stuff  boolean  &  put  addr  on  stack 

ret 

*************************  Lor  ********************************** 
Takes  logical  or  of  two  booleans  and  stacks  address  of  answer 

lor:     call  igetvalue  ;get  1st  boolean  off  stack  to  the  ex 
reg 

mov  bx,  ax  /save  boolean 

call  igetvalue  /get  2nd  value  using  the  stack  ptr 

or  ax,  bx  /Perform  or 

call  iputvalue  /Put  value  into  varspace  &  in  stack 

ret 

************************  Land  ********************************** 
Takes  logical  and  of  two  booleans  and  stacks  address  of  answer 

land:    call  igetvalue  /get  1st  boolean  off  stack  to  ex  reg 

mov  bx,  ax  /save  value 

call  igetvalue  /get  second  value  using  stacK  ptr 

and  ax,  bx  /Perform  and 

call  iputvalue  /Push  boolean  address  onto  stack 
ret 

************************  i ecru  *********************************** 
Takes  logical  equal  of  two  integers  and  stacks  address  of  answer 

iequ:       call  igetvalue  /get  1st  int  off  stack  to  the  ex  reg 

mov  bx,  ax  /save  value 

call  igetvalue  /get  2nd  value  using  the  stack  ptr 

cmp  ax,  bx 

je  eql  /Jump  if  equal 

mov  ax,  FALSE  /put  false  value  into  varspace 

cont :        call  iputvalue  /Put  value  into  varspace,  addr  on  stack 
ret 

eql:     mov  ax,  TRUE  /put  true  value  into  varspace 

jmp  cont 
ret 
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************************    inecr    *********************************** 
Takes    logical    not    equal    of    two    integers    and   stacks    address    of    answer 


ineq:  ■    call    igetvalue 

mov   bx,    ax 
call    igetvalue 
cmp   ax,    bx 
jne    neql 
mov   ax,     FALSE 
fal:  call    iputvalue 

ret 


; get    1st    int    off    stack    to   the   ex    reg 

;save   value 

; get    second   value    using    stack    ptr 

;Jump    if   equal 
;put    false   value    into   varspace 
;Put    value    into   varspace,    addr    on    stack 


neql:  mov   ax,    TRUE 

jmp    fal 
ret 


;put    true   value    into   varspace 


*************************    Ht    ********************************** 
Takes    logical    less    than   of    two    integers    and   stacks    address    of    answer 
Returns    true    if    first    value    is    less    than   the    second   value 


lit:  call    igetvalue 

mov   bx,    ax 
call    igetvalue 
cmp    ax,    bx 
jge    less 
mov   ax,    TRUE 
con:  call    iputvalue 

ret 


;get    1st    int    off    stack    to   the    ex    reg 

; save   value 

;get  2nd  value  using  the  stack  ptr 

; Compare 

; Jump  if  less 
;put  false  value  into  varspace 
;Put  value  into  varspace,  addr  on  stack 


less:    mov  ax,  FALSE 
jmp  con 

ret 


;put  true  value  into  varspace 


*************************    Xot.    ********************************** 

Takes    logical   greater   than    of    two    integers    and   stacks    address    of    answer 

Returns    true    if    first    value    is    greater    than   the    second  value 


Igt :  call    igetvalue 

mov   bx,     ax 
call    igetvalue 
cmp   ax,    bx 
jle   greater_than 
mov   ax,     TRUE 
conl:  call    iputvalue 

ret 


;get    1st    int    off    stack    to    the    ex    reg 

/save    value 

; get  second  value  using  stack  ptr 

/Compare 

/Jump  if  greater  than 
/put  false  value  into  varspace 
/Put  value  into  varspace,  addr  on  stack 


greater_than :   mov  ax,  FALSE 

jmp  conl 
ret 


/put  true  value  into  varspace 


************************    iitecj   ********************************* 

Takes    logical    <   of    two    integers    and   stacks    address    of    answer 

Returns    true    if    first    value    is    less    than    or   equal    to    the    second   value 


Ilteq:        call    igetvalue 
mov   bx,    ax 
call    igetvalue 
cmp   ax,    bx 
jg    lteq 


/get    1st    int    off    stack    to   the    ex    rec 

/save   value 

/get  2nd  value  using  the  stack  ptr 

/Compare 

/Jump  if  less  to  error 
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mov  ax,  TRUE 
con2 :    call  iputvalue 
ret 


'put  false  value  into  varspace 
Put  value  into  varspace,  addr  on  stack 


lteq:    mov  ax,  FALSE 
jmp  con2 

ret 


^put    true    value    into    varspace 


************************    iq-tecr   ********************************* 
Takes    logical   >   of    two    integers    and   stacks    address    of    answer 
Returns    true    if    first    value    is    greater   than   or   equal    to    the    second 
value 


Igteq:        call    igetvalue 
mov   bx,    ax 

call    igetvalue 
cmp   ax,    bx 
jl      gteq 
mov   ax,    TRUE 
con3:  call    iputvalue 

ret 


;get    1st    int    off    stack    to    the    ex    reg 

; save    value 

;get  second  value  using  stack  ptr 

/Compare 

;  Jump  if  greater  than  or  equal  to 
;Pput  false  value  into  varspace 
/Put  value  into  varspace,  addr  on  stack 


gteq:    mov  ax,  FALSE 
jmp  con3 
ret 


;put  true  value  into  varspace 


******************************************************************* 

*  Integer   Operations  * 

******************************************************************* 

*************************    i add    ************************************ 

Adds    two    integer   values 

Assumes    offset    off    second  value    is    in   SI    register 

Offset    of    first    value    is    at    the   top   of   the   stack 


ladd:        call    igetvalue 
mov   bx,    ax 
call    igetvalue 
add   ax,    bx 
jo   err 


;First    value    to   ex    register 

/Perform   addition 

;if    overflow,    run   time   error 


call    iputvalue 
ret 


;Put    integer    into   varspace 


err:  mov  dx,    offset    add_err 

call    print_s 
call    eoln 
call    finis 
ret 


; Error    handler    for    overflow 


. *************************    i Sub    ********************************* 

;Subs    two    integer    values 

/Assumes    offset    off    second  value    is    in   SI    register 

/Offset    of    first   value    is    at    the   top   of   the    stack 


isub:        call    igetvalue 
mov  bx,    ax 
call    igetvalue 
sub   ax,    bx 


/First    value    to   ex    register 
/Perform   subtraction 
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jo   errs  /if    overflow,    run    time   error 

call    iputvalue  ;Put    integer    into    varspace 

ret 

errs:       mcv   dx,    offset    sub_err  ;Print    error   message   on    overflow 

call    print_s 
call   eoin 
call    finis 
ret 
*************************    iMult    ********************************* 

Multiplies    two    integer   values 

Assumes    offset    off    second   value    is    in    SI    register 

Offset    of    first    value    is    at    the    top   of    the    stack 

imult : 

call    igetvalue 
mov   bx,    ax 

call    igetvalue  ; First    value   to   ex    register 

imul    bx  /Perform  mult,    result    in    AX 

jc   errl  ;if    carry    set,    run   time   error 

} 

call    iputvalue  ;Put    integer    into    varspace 

rec 

errl:       mov  dx,    offset   mul_err  ;put    error    message    in   dx    register 

call    print_s  /print    it 

call   eoln 

call    finis  ;end 

ret 

. *************************    iDivn    ********************************* 

/Divides    two    integer   values,    result    in   varspace,    address    of    result 

stacked 

/Offset  of  first  value  is  at  the  top  of  the  stack 

idivn :      push  ex  ;Save  Registers 
push  dx 

call  igetvalue  ;Get  divisor 

mov  bx,  ax  ; Mov  divisor  to  bx 

call  igetvalue  ;Get  dividend  to  ax 

xor  dx,  dx  ; Set  dx  to  0 

mov  cl, i  ;cl  and  ch  are  negative  flags 

mov  ch,  1 

emp  bx, 0 

jg  test2  ;bx  is  positive,  no 'action  needed 

je  errd  ;bx  is  0,  ERROR 

neg  cl  ;bx  is  negative,  cl  flag  negated 

neg  bx  ;bx  is  made  positive 

test2  :     emp  ax,0  ;test  dividend 

jge  dloop  /dividend  >=  0,  no  action 

neg  ch  /ax  is  negative,  ch  flag  negated 

neg  ax  /ax  is  made  positive 

dloop:      sub  ax,bx  /loop  and  count  subtractions 

emp  ax,  0 

jl   dene  /if  ax  less  than  0,  done 

inc  dx  /store  result  in  dx 

jmp  dloop  /continue  loop 
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done:       mov  al,  cl  /Multiply  ch  and  cl 

mul  ch 

cmp  al, 0 

jge-dend  ;if  product  not  negative,  no  action 

neg  dx  ;else  negate  answer 

dend:    mov  ax,dx 

pop  dx 

pop  ex 

call  iputvalue  ;Put  integer  into  varspace 

ret 

errd:  mov  dx,  offset  div_err              ;put  error  message  in  dx  register 

call  print_s                              ;print  it 

call  eoln 

call  finis                                ;end 
ret 

*********************************************************************** 

*  Function   Calling  Procedures  * 

*  * 
*********************************************************************** 

******************************    j_   mov    ********************************** 
Movs    integer    or   boolean   actuals    with   addresses    at    the    top   of    stack    to 
the    lowest    addresses   within   a   scope 
Assumes   bx  has    number   of   actuals   needed  to   be  moved 

i_mov:  pep    ret_addr  ;Save    i_mov's    return    address 

call    add_scope 
strt:  pop   dx  ;rnov   addresses    to    ex   and   dxi    regs 

pop   ex 

call    find_addr  ;Get    virtual    address    of    the    integer 

mov  di,    ex 

mov   ax,    es:vars    [di]  ;Set    up   ax    for    iassign 

call    iassign 
dec   bx 
cmp   bx, 0 
jne    strt 

push    ret_addr  /Restore    i_mov's    return    address 

ret 

.*********************    j    £q rma i    ************************************ 
;Puts    a    formal    to    the    top    of    the    stack 
/Assumes    offset    of    formal    in   ex   register 

i_formai:       mov  di,0 

mov  di,    s_nest[di]  /Get    nesting    level 

call    ppush  /Push    offset    and    nest    onto    stack 

ret 

*********************************************************************** 

*  * 

*  Variables  * 

*  * 

*********************************************************************** 
dseg 
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.  ******************************    Constants    ****************************** 

TRUE  EQU  1 

FALSE  EQU  0 

SPACE_TOP  EQU  2,2100  ;  Top    of    memory    space 

.*************************    intecrer   Variables    *************************** 

max_offset  dw     0  /Maximum   current    offset    w/in    scope 

curr_addr  dw     -32700  /Current    maximum    address 

s_link  dw     SPACE_T0P  /Current    address    of    static    link 

S_nest  dw     0  /Current    static    nesting    level 

ret_addr      dw     0 

.**************************  Error   Messaaaes    **************************** 

div_err  db      'DIVISION    BY    ZERO,    FOOL!' 

db      '  $' 

mul_err  db      'MULTIPLICATION   OVERFLOW,     IDIOT!' 

db      '$' 

add_err  db      'ADDITION   OVERFLOW,    DIMWIT!' 

db     'S' 

sub_err  db      'SUBTRACTION    OVERFLOW,     NITWIT!' 

db      '  $  ' 

crash  db  'STACK/VARIABLE    SPACE    CRASH' 

db      '$' 


.**************************    Error   Messaaoes 

eseg 

vars  dw     0 

end 


**************************** 
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APPENDIX  N  -  TEST  SUITE 


SIMPLE  TESTS  OF  FUNCTIONS  AND  VARIABLES 

let  c  :  $Z  ->  $Z; 

c  (20)  where  c  (n)  ==  if  1  =  2  then  3  *  n 
else  3  +  n  endif 

--Simple  "Hello  I'm  Alive  Test" 


let  c  :  $Z  ->  $Z; 

c  (1  *  2)  where  c  (n)  ==  n  *  3 

-  Test  for  expression  in  functions's  formals 


let  c  :  $Z  ->  $Z; 

c  (k  +  2)  where  k  ==  2  and 

c  (n)  ==  if  n  =  1  then  n  *  3  else  n  +  4  endif 

-  Test  for  expression  in  function's  formals 


TESTS  FOR  RECURSION 

let  c  :  $Z  ->  $Z; 

c  (k  *  2)  where  k  ==  2  and  c  (n)  ==  n  *  3 

—  Test  for  expression  in  function's  formals 

let  c  :  $Z  ->  $Z; 

c  (0)  where  c  (n)  ==  if  n  =  0  then  1  else  c  (n  -  1)  *  n  endif 

-  Test  for  recursion  in  functions 

let  c  :  $Z  ->  $Z; 

c  (5)  where  c  (n)  ==  if  n  =  0  then  1  else  c  (n  -  1)  *  n  endif 

~  Test  for  recursion  in  functions 

let  c  :  $Z  ->  $Z; 

157 


c  (3)  where  c  (n)  ==  if  n  =  0  then  1  else  n  *  c  (n  -  1)  endif 
--  Test  for  recursion  in  functions 

let  c  :  $Z  ->  $Z; 

c  (7)  where  c  (n)  ==  if  n  =  0  then  1  else  n  *  c  (n  -  1)  endif 

--  Test  for  recursion  in  functions 

TESTS    OF    COMPLEX    FUNCTIONS,    INCLUDING    BOOLEANS    AS 
ARGUMENTS  AND  RESULTS 

letc:$Z->$B; 

c  (1)  where 

c  (n)  ==  n  =  6 

—  Test  for  booleans  in  function 

let  c  :  $Z  *  $Z  *  $Z  ->  $Z; 

c(2  -  1,3,4)  where  c(n,m,x)  ==  n  *  m  *  x 

--Test  for  multiple  arguments 


letc:$Z->$B; 
let  d  :  $Z  ->  $Z; 

c  (1)  where 

c  (n)  ==  1  =  d(l)  where 
d(k)  ==  k 


Test  for  chaining  in  functions 


let  c  :  $Z  ->  $Z; 

let  d  :  $Z  ->  $Z; 
lete  :$Z->$B; 
c  (3)  where 

c  (n)  ==  1  +  d(n)  where 
d(k)==ife(l) 
then  k  else  k  +  1  endif 
where  e  (k)  ==  k  =  3 

-  Test  for  nesting  in  functions 
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let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $B; 

c  (3)  *  10  where 

c  (n)  ==  1  +  d(n)  where 
d(k)==ife(l) 
then  k  else  k  +  1  endif 
where  e  (k)  ==  k  =  3 

—  Test  for  nesting  in  functions,  result  multiplied  by  constant 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $B; 

c  (3)  *  c(4)  where 

c  (n)  ==  1  +  d(n)  where 
d(k)==ife(l) 
then  k  else  k  +  1  endif 
where  e  (k)  ==  k  =  3 
and  b  ==  10 

--  Test  for  two  functions,  same  definition 

—  Also,  test  for  extraneous  variable  defined  at  end  of  program 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
lete:$B->$B; 

c  (3)  *  c(4)  where 

c  (n)  ==  1  +  d(n)  where 

d(k)==ife(2  =  3A4  =  5) 
then  k  else  k  +  1  endif 
where  e  (k)  ==  k 

--  Test  for  boolean  expression  as  an  actual 


TESTS  FOR  "AND"  AND  "WHERE"  NESTING  AND  COMBINATIONS 

let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 

c  (3)  *  b  where  b  ==  10  and 

c  (n)  ==  n  *  d  (n)  where 
d(n)==3 

~  Test  for  nesting  in  functions 
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let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 

c  (3)  *  b  where  b  ==  10  and 

c  (n)  ==  n  *  d  (n)  where 
d  (n)  ==  3  *  e  where  e  ==  10 

—  Test  for  nesting  in  functions 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $Z; 

c  (3)  +  b  where  b  ==  10  and 

c  (n)==d(l)  +  if  n  =  e  (1)  then  2  else  lOendif 
where  e  (k)  ==  - 1  and 
d  (g)  ==  g  +  5 


--  Test  for  nested  wheres  and  ands 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $B; 

c  (3)  where 

c  (n)  ==  1  +  d(n)  where 

d(k)  =  if  e(l)  then  k  else  k  +  1  endif 
where  e  (b)  ==  b  =  3 

--  Test  for  nesting  in  functions 


let  c  :  $Z  ->  $Z; 
let  d :  $Z; 

c(5)  where  c  (n)  ==  d 
and  d  ==  10  *  5 

--  Test  for  single  and  statement 
-  Test  for  datadef  declaration 


let  c  :  $Z; 
let  d :  $Z; 
let  e  :  $Z; 

c  where  c  ==  (d  +  10  +  e  where  e  ==  10) 
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and  d  ==  10 

Test  for  Multiple  ands 


let  c  :  $Z; 
let  d :  $Z; 
let  e  :  $Z; 

c  where  c  ==  d  +  10  +  e 
and  d  ==  10 
and  e  ==  10 

-  Test  for  Multiple  ands 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $Z; 

c(5)  where  c(n)  ==  d(n)  +  12 
and  d(s)  ==  10  +  s 

--  Test  for  Multiple  ands  using  functions 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $Z; 

c(5)  where  c(n)  ==  d(n)  +  12 
and  d(s)  ==  10  +  e  (s) 
and  e(k)  ==  20  +  k  +  t  where  t  ==  100 

--  Test  for  Multiple  ands  ,  nested  wheres 


let  c  :  $Z; 
let  d  :  $Z; 
let  e :  $Z; 

c  where  c  ==  d  +  10  +  e  where 

e  ==  10  and  d  ==  10 
-Test  for  Multiple  ands 


let  c  :  $Z  ->  $B; 
let  d  :  $Z  ->  $B; 
let  k  :  $Z  ->  $Z; 
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c(l)  A  d(2)  where 
c  (n)  ==  n  =  3  and 

d  (n)  ==  (1  =  k  (n  -  1)  where 
k  (1)  ==  1  +  10) 


-  Test  for  proper  use  of  "and"  and  implementation  of 
--  Parens 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $Z; 

c(5)  where  c(n)  ==  d(n)  +  12  where  k  ==  100 
and  d(s)  ==  10  +  e  (s) 
and  e(k)  ==  20  +  k 

--  Test  for  Multiple  ands,  multiple  wheres  and  formal/variable  collisions 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $Z; 

c(5)  where  c(n)  ==  d(n)  +  12  where  k  ==  100 
and  d(s)  ==  10  +  e  (s)  where  t  ==  100 
and  e(k)  ==  20  +  k  +  t 

--  Test  for  Multiple  ands,  multiple  wheres  and  formal/variable  collisions 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $Z; 

c(5)  where  c(n)  ==  d(n)  +  12  where  t  ==  100 
and  d(s)  ==  10  +  e  (s)  where  t  ==  120 
and  e(k)  ==  20  +  k  +  t 

--  Test  for  Multiple  ands,  multiple  wheres  and  formal/variable  collisions 
--  Also  test  to  see  if  the  proper  "t"  (120)  was  picked  up 


let  c  :  $Z  *  $Z  ->  $Z; 

let  d  :  $Z  *  $Z  ->  $Z; 
let  e  :  $Z  *  $Z  ->  $Z; 
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c(5,l)  where  c(n,m)  ==  d(n,m)  +  12  where  t  ==  100 
and  d(s,z)  ==  10  +  e  (s,z)  where  t  ==  120 
and  e(k,l)  ==  20  +  k  +  t  +  1 

-  Test  for  Multiple  ands,  multiple  wheres  and  formal/variable  collisions 
--  Test  specifically  for  functions  with  multiple  arguments 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $Z; 

c(5)  where  c(n)  ==  d(n)  where  t  ==  100 
and  d(s)  ==  (e  (s)  where  k  ==  2) 
and  e(k)  ==  20  +  t 

--  Test  for  Multiple  ands,  multiple  wheres  and  formal/variable  collisions 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $Z; 

c(10)  where  c(n)  ==  d(n)  where  t  ==  100 
and  d(s)  ==  e  (s)  where  k  ==  10 
and  e(r)  ==  20  +  r  +  k 

--  Test  for  Multiple  ands,  multiple  wheres  and  formal/variable  collisions 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $Z; 

c(10)  where  c(n)  ==  d(n)  +  t  where  t  ==  (r  *  100  where  r  ==  2) 
and  d(s)  ==  e  (s)  where  k  ==  10 
and  e(r)  ==  20  +  r  +  k 

--  Test  for  Multiple  ands,  multiple  wheres  and  formal/variable  collisions 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $Z; 

let  f :  $N  ->  $Z; 

c(10)  where  c(n)  ==  d(n)  +  t  where  t  ==  (r  *  100  where  r  ==  2) 
and  d(s)  ==  e  (s)  where  k  ==  10 
and  e(r)  ==  20  +  r  +  f  (r) 
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and  f(r)  ==  r 
--  Test  for  Multiple  ands,  multiple  wheres  and  formal/variable  collisions 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $Z; 

let  f :  $N  ->  $Z; 

c(10)  where  c(n)  ==  d(n)  +  t  where  t  ==  (r  *  100  where  r  ==  2) 
and  d(s)  ==  e  (s)  where  k  ==  10 
and  e(r)  ==  20  +  r  +  f  (r) 
and  f(r)  ==  k 

--  Test  for  Multiple  ands,  multiple  wheres  and  formal/variable  collisions 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $Z; 

let  f :  $N  ->  $Z; 

c(10)  where  c(n)  ==  d(n)  +  t  where  t  ==  (r  *  100  where  r  ==  2) 
and  d(s)  ==  e  (s)  where  k  ==  10 
and  e(r)  ==  20  +  r  +  f(r) 
and  f(r)  ==  if  r  =  0  then  100  else  f  (r  -  1)  endif 

--  Test  for  Multiple  ands,  multiple  wheres  and  formal/variable  collisions 
--  Test  for  if-then-else  collisions  with  multiple  ands,  wheres 


let  c  :  $Z  ->  $Z; 
let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $Z; 

let  f :  $N  ->  $Z; 
let  zebra :  $Z; 

c(10)  where  c(n)  ==  d(n)  +  t  where  t  ==  (r  *  100  where  r  ==  2) 
and  d(s)  ==  (e  (s)  where  k  ==  10 
and  e(r)  ==  20  +  r  +  f(r)  +  zebra 
and  f(r)==ifr  =  0  then  100  else  f(r-  1)  endif 
and  zebra  =  t) 

--  Test  for  Multiple  ands,  multiple  wheres  and  formal/variable  collisions 
--  Test  for  if-then-else  collisions  with  multiple  ands,  wheres 


let  c  :  $Z  ->  $Z; 

let  d  :  $Z  ->  $Z; 
let  e  :  $Z  ->  $Z; 
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c(5)  where  c(n)  ==  d(n)  +  12  where  t  ==  100 
and  d(s)  ==  (10  +  e  (s)  where  k  ==  100 
and  e(k)  ==  20  +  k  +  t) 

--Note  the  use  of  parenthesis  here  :  if  they  are  removed,  the  program  will 
-bomb  because  t  will  be  undefined 


ERROR  TESTING 

let  x  :$z; 
letj:$Z; 
let  i:$z; 


i  where  i  ==x%j 

and  x  ==5  and  j  ==0 

-  Gives  Division  by  Zero  run  time  error 


let  b:$b; 
let  i:$Z; 
let  j:$z; 
let  n:$n; 
let  x:  $z; 

if  b  then  i 

elsif  ~(b  A  b)  then  j 

else  x  endif     where 

b  ==  i=2  where 
i==0 

and  where  j 

and  where  z  ==  69 

-  Gives  two  parser  errors  :  line  13  and  14,  j  undefined  and 

-  where  following  "and" 

let  fac  :  $N  ->  $N; 

fac  (5)  where  fac  (n)  ==  fac  (n  -  1) 

-  Check  for  stack  overflow 


too_much  where  too_much  ==  1000  *  1000 

-  Check  for  Multiplication  Overflow 

too_much  where  too_much  ==  30000  +  30000 

-  Check  for  Addition  overflow 
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too_much  where  too_much  ==  -30000  -  30000 
--  Check  for  Subtraction  Overflow 


letc  :$Z->$B; 
letd:$Z->$B; 
let  k  :  $Z  ->  $Z; 
let  g  :  $Z  ->  $Z; 

c(l)  A  d(2)  where 

d  (n)  ==  ( 1  =  k  (n  -  1 )  where 
k  (1)  ==  1  +  10)  and 
c  (n)  ==  n  =  3 

--  Test  for  proper  use  of  comments;  note  that  there  is  no 

delimiter  on  the  second  line  of  comments,  as  there  should 
--be 


MISCELLANEOUS  TESTS 

let  b:$b; 
let  i:$Z; 
let  j:$z; 
let  n:$n; 
let  x:  $z; 

if(bV~b)theni 
elsif  (b  V  ~b)  then  j 
else  x  endif     where 

b  ==  i=2  where 
i==0 

and  j  ==2 

and  x  ==  69 
-  Test  for  not  construct,  boolean  constructs 


let  b:$b; 
let  i:$Z; 
let  j:$z; 
let  n:$n; 
let  x:  $z; 

if~(bV~b)theni 
elsif  ~(b  A  ~b)  then  j 
else  x  endif     where 

b  ==  i=2  where 
i==0 

and  j  ==2 

and  x  ==  69 
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--  should  give  2 

--  Check  and,  or,  notand,  notor 

--  Check  if,  else,  elseif 

-  Especially,  check  all  in  combination 


let  a:$Z; 

let  b:$z; 

let  y:$n; 

let  x:  $z; 

let  f:  $n*$n->$n; 

let  times  :  $n*$n->$n; 

f(30,30)  where 

f(a,b)  ==  times(a,b)  where 
times(x,y)  ==  x*y 

-  Multiargument  Checking 

—  Natural  Type  Checking 


let  a:$Z; 

let  b:$z; 

let  y:$z; 

let  x:  $z; 

let  f:  $z*$z->$z; 

let  times  :  $n*$n->$z; 

f(30,4)  where 

f(a,b)  ==  times(a,b)  where 
times(x,y)  == 
if  (  1  =  l)thenx%y 
else  2  endif  end 
—  Integer  Division  Checking 


let  c  :  $Z  ->  $B; 
letd:$Z->$B; 
let  k  :  $Z  ->  $Z; 
let  g  :  $Z  ->  $Z; 

c(l)  A  d(2)  where 

d  (n)  ==  (1  =  k  (n  -  1)  where 
k  0)  ==  1  +  10)  and 
c  (n)  ==  n  =  3 

--  Test  for  proper  use  of  "and"  and  implementation  of 
-  Parens 
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APPENDIX  O  -  ROCK  COMPILER  USER'S  MANUAL 


I.        Installation 

The  rock  compiler  program  comes  on  a  5.25"  disk  with  all 
public  domain  programs  necessary  to  run  it.    To  install  this 
program  on  another  floppy  disk  or  a  hard  disk,  use  the  following 
procedures: 

1)  Change  the  system  drive  to  the  disk  drive  containing  the 
floppy  disk. 

2)  Type  "INSTALL",  followed  by  a  space  and  the  drive  and 
directory  on  which  you  want  the  program  installed. 

Note  that  the  Rock  compiler  uses  three  unsupplied  files  to 
operate:  RASM86,  LINK86,  and  your  choice  of  word  processor.  The 
RASM86  and  LINK86  programs  must  be  installed  on  the  same 
directory  as  the  compiler. 


II.     Running  the  Compiler 

a.    Type  in  "ROCK"  and  wait  for  the  screen  display  shown  in 
figure  1  to  appear. 


ROCK  COMPILER 
Press  Escape  Key  to  Exit  Compiler 


Program  to  Compile  -> 


Figure  1 

b.  When  the  prompt  appears,  type  in  the  file  name  of  the 
source  file  you  want  to  compile,  then  press  return.  The 
compiler  will  accept  directory  specifications  in  the 
file  designation.    If  the  source  file  is  found,  the 
compilation  will  begin  immediately,  and  the  screen  will 
appear  as  shown  in  figure  2.    If  the  file  is  not  found, 
the  screen  will  appear  as  shown  in  figure  3. 
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c.    If  a  successful  compilation  takes  place,  the  prompt  for 
a  source  file  reappears.    If  the  compilation  is  not 
successful,  error  messages  will  appear  on  the  screen, 
and  a  copy  of  these  messages  can  be  found  in  a  file 


ROCK  COMPILER 
Press  Escape  Key  to  Exit  Compiler 


Program  to  Compile  ->      SQRT.PHI 

Compiling:  Please  Wait 


Figure  2 


ROCK  COMPILER 
Press  Escape  Key  to  Exit  Compiler 


Program  to  Compile  ->    NOTFOUND 


File  not  Found 
Press  ESCAPE  to  exit,  any  other  key  to  continue 


Figure  3 

named  Errors.Phi.  A  typical  error  display  is  shown  in 
figure  4.  After  perusing  the  errors,  you  may  press  any 
key  to  return  to  the  prompt  for  a  source  file. 
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ROCKY  ERRORS 


line   1  :   formals  list  missing  or  error  in  formals  list 
line  1  :  misplaced  or  missing  = 
number  of  errors  =  2 


PRESS  ANY  KEY  TO  CONTINUE 


Figure  4 

d.  If  compilation  is  successful,  both  an  .exe  and  an  .obj 
file  will  be  created.    In  the  event  that  an  error 
occurs,  neither  file  will  be  created. 

WARNING  :  If  you  choose  to  compile  two  programs  with  the 
same  prefix,  ensure  you  save  the  first  one  before 
compiling    the  second  one;    otherwise,    the  second 
compilation  will  overwrite  the  output  file  of  the  first 
compilation. 

e.  To  cleanly  stop  the  compiler,  press  the  ESCAPE  key  any 
time  the  system  asks  for  an  input.    If  you  have  started 

to  compile  a  program  and  you  need  a  "panic"  exit,  press 
"Control-Break".    If  you  do  this,  the  cursor  will  not 
reappear  on  the  screen.  However,  you  can  get  it  back  by 
running  the  ROCK  program  again  and  making  a  normal  exit. 


III.  Error  Handling 

Errors  are  divided  into  two  categories  :  those  found  during 
compilation  and  those  found  during  run  time.    The  following  two 
sections  list  the  errors  messages  from  both  categories  which  you 
might  encounter.    Each  message  includes  a  brief  synopsis  of  what 
causes  the  error. 

COMPILER  ERRORS 

Message  Explanation 

incomplete  'l->'  Either  an  "I"  or  "I-"  was  found 

where  "l->"  was  expected. 

V  without  following  '/',  A  single  backslash  was  found 

logical  OR  is  V  where  a  logical  or  construct 

(V)  was  expected. 
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'$'  without  following 
■RVNVZVB'.or    '1' 

invalid  numeric 
constant  ==>  3. 

literal  without  ending 


An  incomplete  type  declaration  was  found. 


An  illegal  constant  was  found; 
in  this  example,  "3." 

An  unterminated  literal  was 
found,  or  a  literal  spanned 
more  than  one  line. 


unidentified  char 

in  input  program  ==>  # 

MEMORY  OVERFLOW 
DURING  COMPILATION 


A  character  with  no  meaning  was 

found  in  the  source  file;  '#',  in  this  example. 

The  source  program  is  too  big 
for  the  host  machine  to  compile. 


error  in  statement 
following  ==>  * 


An  illegal  statement  follows 

the  specified  character,  '*',  in  the  example. 


error  in  type 

definition  following  ==>  * 


unable  to  complete 
definition  of  blockbody 
after  keyword  LET 


An  illegal  type  definition  follows  the 
specified  character;  '*',  in  the  example. 

An  unspecified  error  was  found 
after  LET,  and  the  compiler  is 
so  completely  sandbagged  that 
it  cannot  recover. 


missing  or  misplaced  ';' 
after  definition 

valid  qualexp/exp 

not  found  in  the  def/auxdef 

valid  typeexp  not  found 
in  the  def 

formals  list  missing 
or  error  in  formals  list 

misplaced  or  missing  ')' 


at  least  one  identifier 

must  follow  keyword  TYPE 

unable  to  complete 
def/auxdef  following 
keyword  AND 


A  declaration,  preceded  by 

"LET",  was  not  followed  by  a  semicolon. 

An  invalid  expression  was  found 


An  expression  defining  a 

type  was  either  missing  or  incorrect. 

Formals  were  expected  but  not  found, 
or  formals  were  incompletely  specified. 

A  PHI  keyword  or  delimiter  was 
expected  or  not  found;  ')'  in  the  example. 

TYPE  found  without  an  identifier. 


Improper  or  no  expression  found 
following  AND. 
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missing  or  invalid  auxdef 
after  keyword  WHERE 

missing  or  misplaced 
closing  paren  in  formals 
list 


Improper  or  no  definition  following 
WHERE 

Formals  found  without  closing 
parenthesis. 


error  in  processing 
multiple  Actuals 

missing  literal 
after  keyword  FILE 

missing  or  invalid 

exp  following  KEYWORD 

IF  statement  w/o  ENDIF 

error  in  formals 
preceding  l-> 

missing  or  invalid 
QualExp  following 
COMMA  operator 

error  in  ArgBinding 
-  check  QualExp 
or  closing  bracket 


One  actual  was  found,  but  an 

error  was  spotted  in  a  subsequent  actual. 

FILE  was  found  without  a  file- 
name being  designated. 

A  keyword  was  spotted,  but  the 
following  expression  was  illegal. 

No  ENDIF  to  close  off  an  IF  statement. 

"l->"  found,  but  the  formals 

list  preceding  it  contained  an  error. 

A  list  of  elements  was  found 
with  an  illegal  expression  in  it. 


An  improper  expression  in  an 
argument  binding  was  found,  or 
the  closing  bracket  on  an  argument  binding 
was  not  found. 


OZONE  LEVEL  I  - 


NUMERIC  VALUE  EXPECTED 


NATURAL  EXPECTED 


Unimplemented  feature  found, 
for  19.99  the  feature  can  be 
implemented  in  1999 

Non- numeric  type  found  where  a 
numeric  type  was  expected. 

Natural  type  was  not  found  where 
it  was  expected. 


INTEGER  OR  NATURAL  EXPECTED       Either  an  integer  or  natural  type 

is  proper,  but  neither  was  found. 


ERROR  IN  TUPLE  DEFINITION 


UNDEFINED  VARIABLE 
IN  AND  SCOPE 


A  tuple  is  improperly  defined  : 

the  source  file  used  improper 

types  or  number  of  types  in  defining 

the  tuple.  This  can  also  mean 

a  single  variable  was  improperly  defined. 

An  undefined  variable  was  found 
in  one  of  the  two  branches  of  an 
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FUNCTION  WITHOUT 
FUNCTION  DEFINITION 

FORMALS  MISMATCHED 


FUNCTION  CALLED  WITHOUT 
FUNCTION  DEFINITION 

REAL  NUMBER  EXPECTED 


INVALID  CONSTANT 
EXPRESSION 

BOOLEAN  VALUE  EXPECTED 


BOOLEAN  OPERATOR  EXPECTED 


OUT  OF  RUN-TIME 
MEMORY  SPACE 


in  its  scope. 

A  function  was  defined  without  a 
declaration  of  its  type  and  formals. 

Formals  in  a  function  definition 

are  not  the  same  in  either  type  or 

number  as  those  in  the  function's  declaration. 

No  function  definition  found  for 
the  function  called. 

An  incorrect  type  was  found  where 
a  real  number  was  expected. 

An  invalid  constant  was  found. 


A  boolean  value  was  expected,  but 
none  was  found. 

A  boolean  operator  was  expected, 
but  none  was  found. 

Not  enough  space  to  accommodate  the 
program  during  run-time. 


DIVISION  BY  ZERO 


RUN-TIME  ERRORS 

Division  by  zero  attempted. 


MULTIPLICATION  OVERFLOW 
ADDLTION  OVERFLOW 


A  multiplication  operation  resulted  in 

a  numeric  value  outside  the  language  limits. 

An  addition  operation  resulted  in 

a  numeric  value  outside  the  language  limits. 


SUBTRACTION  OVERFLOW 


A  subtraction  operation  resulted 
in  a  numeric  value  outside  the 
language  limits. 


STACK/VARIABLE  SPACE  CRASH    The  stack  overwrote  the  variable  space. 
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